Appendix B

Appendix B.

MuP21 eForth Version 2.08

The first batch of MuP21 chips were packaged by Orbit Semiconductor. Actually, Orbit sent the wafers to Phillipines for packaging, and charges a fairly high price for the service. At the time, the concerns was to get the chips manufactured by one vendor to minimize the risks in the manufacturing processed. In one batch, Orbit produced 10 wafers and only 2 were diced and packaged into 40-pin DIP packeges. The chips worked, but not as good as the prototypes. One problem was that the A! instruction does not function properly in slots 1, 2 and 3. The best we could deduce from this strange behavior was that in the plastic DIP packages, the bonding wires are surounded by epoxy and the wire inductance is increased and thus slows down the data stack access time. When A! is executed in slot 2, 3, or 4, the data in the T register have not yet stablized and erroreous data is copied into the A register.

The 44-pin PLCC package is much more attractive because it is about 30% of the 40-pin DIP package, and the bounding wires are shorter. We decided to have the rest of the diced packaged in this form. Searching around in the Silicon Valley, we found a Phillipino company Pacific Semiconductor provided the packaging service at any quantity and at very good price. Thus the rest of the dices cross the Pacific Ocean again and were processed in Phillipines. These PLCC chips are MuP21H. They seemed to work better than MuP21, but we need a printed circuit board to host the new chips for testing and product development.

Last Christmas I want back to Taiwan for a Taipei Forth Conference and and Forth Workshop in the Hsin-Chu Science Based Industrial Park. I sent the PC board layout to Mr. Tsan-te Wong, the chairman of the Taiwan FIG chpater and he helped to get some boards made. John Baumgarner defined the board configuration and the components we needed on this board. He wanted a stable UART for communication with a host PC, and we though that an 82C51 would be a good choice for the UART. We would like to use two input lines to 82C51 to interface to a standard AT-style keyboard as an alternate input device.

This Appendix summarizes the work with MuP21H on this new board. The pin-out diagram of MuP21H is shown in Appendix B1, and the schematics of the new PC board is included in B2. The complete MuP21 eForth system source code is included in B4-B10, with the README file in B3. Appendix B thus contains the complete definition of a MuP21H system and is valuable for those who will want to implement their own systems using the PLCC packaged chips.

B1. MuP21H Pinouts

B2. New PC Board Layout

Bill of Materials

Item Amount Part# Price Comment

Jameco

DRAM SIMM 1 75177 184.95 1Mx36/70

EPROM 1 39669 5.95 M27C010/20

80C51 1 52370 3.75 UART

CD4040 1 12950 0.59 Freq. divider

Max233 1 106163 5.75

14.3M Clock 1 108652 3.29 For video

1.84M Clock 1 27879 3.29 For UART

7805T 1 51262 0.49 Regulator

Power Brick 1 100853 5.75 9V/200mA

Tatalum Cap 2 94094 0.47 22u/16V

Resistor 100K 1 29997

Resistor 82 1 60302

Reset Switch 1 119790 0.69

PLCC Socket 1 71618 1.49 MuP21H

SIMM Socket 1 72426 2.25 DRAM

DIP 40-pin 1 41136 1.19 52C50

DIP 32-pin 1 105380 1.09 M27C010

DIP 20-pin 1 38623 0.79 Max233

DIP 14-pin 2 37169 0.59 Clocks

RCA Socket 1 112475 0.49

DIN5 Socket 1 29399 0.69

DB9 Socket 1 104951 0.65

Mouser

Box 1 546-1598BBK 10.16

LED 1 351-2501 0.49

Capactor 10 58-UDW104M1 0.16 0.1uF

Offete

MuP21H 1 40.00

PCB 1

B3. ReadMe.seq

eForth for Plastic MuP21 Chips

C. H. Ting

Version 2.08 4/8/96

Files: meta28.seq, ok28c.seq, hline27.seq, kernel28.seq, inner.seq

eForth28.seq

1. This version of eForth is specifically designed for the new P21B5 PCB, which uses an 82C51 UART for serial communication with the host PC.

2. P21B5 board hosts the MuP21H in 44-pin PLCC package.

3. Words added to eForth to display characters abd rectangles on TV:

tvAT ( x y -- ) Set current location to (x,y). Top-left (0,0), lower right (19,39).

tvEMIT ( char -- ) Display char at current location. Move current location to right.

tvCR ( -- ) Scroll screen up by one line. Current location is at lower left corner of the screen.

FG ( color -- ) Set foreground color for charaters.

BG ( color -- ) Set background color for characters.

RECTANGLE ( x y width height -- ) Draw a rectangle with foreground color.Width is on 4-pixel boundary.

RECT ( x1 x2 y1 y2 -- ) Draw a rectangle using the 8x8 color pattern stored in 300-30F.

SetColor ( color -- ) Init array 300-30F to a single color for RECT.

SLOW ( -- ) Slow down RS232 sampling to reduce video jitter.

FAST ( -- ) Increase RS232 sampling rate for file downloading.

4. tvCR and tvEMIT form the minimum word set to manage a scrolling screen character display. After tvCR, the screen is scrolled up one line and the bottom line is cleared for character entry. tvAT is added for flexibility to address the screen display randomly.

5. Color code is as follows:

0 Black 8 Black

1 Dark blue 9 Light blue

2 Dark red A Light red

3 Dark brown B Yellow

4 Dark green C Light green

5 Dark cyan D Cyan

6 Dark magenta E Magenta

7 Gray F White

6. Only three baud rate can be selected: 7200, 14.4K and 28.8K by jumpering to appropriate pins on the frequency divider CD4040. Master clock to CD4040 and 82C51 is 1.8432 MHz. 82C51 must be programmed to run at x16 mode. The prescaler divides input clock by 16 to run RxC and TxC.

7. A socket is provided to connect to a standard AT keyboard as an alternate input device. However, this operation has not be explored.

Version 2.07 11/24/95

Files: meta27.seq, ok27c.seq, hline27.seq, kernel27.seq, inner.seq

eForth27.seq

Merge rectangle code with eForth.

Add newColor demo code.

Version 2.06 11/11/95

File name changes: meta26.seq, ok26c.seq, okchar26.seq

I/O is returned to 250ns slow mode to stablize the RS232 communications.

Use 74HC138, 74HC245, 74HC574 for input and output.

Use a 1.8432 MHz clock in the place of 14.318 MHz clock. By slowing

down the video clock input, the timing on RS232 port can be

maintained accurately and the drift of baudrate is greatly reduced.

This makes the serial communication with the host computer stable

and usable.

Add HOST.EXE. This is the host terminal/file server adopted from

Lesson11 in The Forth Course by Richard Haskell.

To download a file from PC to eForth in MuP21:

1. bring up HOST by

C:>HOST

2. Boot eForth

3. Press B or b on host keyboard

4. Test eForth from keyboard

5. Start file down load by typing:

FILE <return>

6. Press F3 to bring up a file selection menu

7. Select file and press return

8. Examine the eForth dictionary by

WORDS

Version 2.04, 2/20/95

This disk contains the beta version of MuP21 eForth v2.02. The files

are:

readme.seq This file

meta.seq Metacompiler. It also loads all other files

ok21c.seq Chuck Moore's MuP21 assembler

okchar21.seq Character generator and RS232 driver

kernel.seq 30 eForth primitives for MuP21

inner.seq Inner interpreters for MuP21 eForth

eforth.seq High level eForth source code

p21ef.rom 32K byte eForth ROM image

Hardware Requirements

This eForth is to be used in the MuP21 Development Board (Offete 4012)

or in the MuP21 Evaluation Kit (Offete 4011). To run eForth, the

board needs the following modifications:

1. Replace 74HC138 by a 74ACT138

2. Replace 74HC245 by a 74ACT245

3. Add 0.1 uF bypass capacitors to 74ACT138 and 74HC574

4. Burn a M27C1001 (200ns or lower) EPROM with p21ef.rom

located between 0-7FFF. Place it in the ROM socket.

5. Connect pin-9 of '245 to TX of host RS232 port

6. Connect pin-19 of '574 to RX of host RS232 port

eForth uses fast I/O mode to communicate with the host. HC parts

are too slow for the input. Running in fast mode, there is a

significant amonut of noise which tends to disrupt the serial

output line. The bypass capacitors are needed to quite down

the system.

Boot the RS232 Interface

Upon power up, the big blue OK sign will be shown on the TV screen.

Pressing the middle switch of the 7 switches will activate the serial

interface and sends the message "MuP21 eForth V2.02" to the host.

Now you can talk to MuP21 via the host keyboard/screen.

Try the following eForth commands:

WORDS

HEX 0 2000 DUMP

SEE WORDS

.FREE

.BASE

: LOOPTEST -1 FOR NEXT ;

LOOPTEST

If the message "MuP21eForth V2.02" is garbled up, the host is not

talking in 9600 baud, 1 start, 1 stop format. Change the host

baud rate to 9600 and reboot MuP21 system. Then press middle

switch.

If the message is still not correct, do the following to change

the baud rate from MuP21. The 7 switches are number 1 to 7, with

switch 1 being the software RESET switch.

1. Press hardware reset switch. OK must be shown on TV screen.

Make sure MuP21 and the host RS232 port are properly connected.

2. Press Switch 3. The TV screen will be darkened.

3. Press Switch 2. Character B will be sent to host.

Hold down Switch 2 and use a scope to observed the

waveform. It should be close to 9600 baud.

4. Press Switch 7 once. This puts MuP21 in a waiting loop,

waiting for a characte 'B' or 'b' to be transmitted from

the host.

5. Press 'B' on the host keyboard.

6. Hold down Switch 2 again, to verify that B's are properly

received by the host.

7. Press Switch 1 once to return to the OK screen. Do not

hold it too long to trigger a software reset. Software

reset will erase the new baud rate you just acquired.

8. Press Switch 4 again to initialize the serial port.

You should see the eForth sign-on message on the host screen.

Failing that, repeat from Step 1.

MuP21 Hardware Debugger

To bring up this eForth system, I implemented a simple hardware

debugger under the OK system. It consists of 4 menus, and the functions

assigned to switches in the following fashion:

Menu Switches

7 6 5 4 3 2 1

OK Debug Dump+ Dump- eForth Test Select Reset

Test (green) SetBaud Dump+ Dump- KeyTest CLS EmitTst OK

Select (blue) Debug Digit3 Digit2 Digit1 Digit0 Stacks Test

Debug (red) Stacks Go3FF Continu Rpt3FF -- Select Test

Functions are:

Dump+ Dump next 80 words

Dump- Dump previous 80 words

eForth Start eForth, locked to serial line

Reset Software reset

SetBaud Wait a 'B' from host and set baud rate

KeyTest Enter an infinite loop to receive characters from

host and display characters on TV screen

CLS Darken the TV screen

EmitTest Send 'B' to the host

Digit3 Decrement digit 3 in memory location 3FF

Digit2 Decrement digit 2 in memory location 3FF

Digit1 Decrement digit 1 in memory location 3FF

Digit0 Decrement digit 0 in memory location 3FF

Stack Dump the stack area from 3B0 to 3FF

User area: 3B0-3BF

Data Stack: 3C0-3DF

Return Stack: 3E0-3FF

IP: 3FC

SP: 3FD

RP: 3FE

Go Address: 3FF

Go3FF Jump to address in 3FF, init SP to 3C0 and RP to 3E0

Break at the next EXIT

Continue Continue execution till the next break at EXIT

Rpt3FF Jump to address in 3FF, do not init SP and RP

To break at EXIT, eForth needs to be recompiled with the phrase

' WAIT alias ;;

enabled and the phrase

' EXIT alias ;;

commented out.

With WAIT installed in places of EXIT at the end of all the colon

definitions, you can choose a colon definition by put its address

(plus 1, to the address list) in 3FF and press 'Go3FF' switch.

MuP21 will execute the list and stop at the next WAIT (EXIT). The

stacks, pointers and the user area are refreshed for inspection.

Press 'Continue' will continue the execution and stop at the next

WAIT (EXIT).

To select a word to trace, go the the Select Menu and use the

Digit3, Digit2, Digit1, and Digit0 switches to change the address

in 3FF. When you have the desired address in 3FF, press 'Debug'

to go the the Debug Menu. Use Go3FF to start execution, and

Continue to trace the code. If you like to look at other memory

locations, press 'Test' to get to the Test Menu and then the

Dump switches to scan the memory. Press 'Debug' to continue

tracing.

This debugger is very crude and not very convenient. It served

my purpose of bringing up the interpreter of eForth. Once the

interpreter is up and working, debugging the rest of the system

is but a breeze. However, it can be very useful when you have

to enhance eForth. So, I present this debugger as a challenge

to you. Try to make it more versatile and easier to use. Extend

it so you can use it to debug native MuP21 machine code programs.

The Metacompiler

The purpose of this metacompiler is to build the eForth system

on the top of the OK system originated from Chuck Moore. I took a

short cut. Instead of insisting on building in in MASM, I tried

to use the eForth source code provided by Bill Muench. The OK

system is extended to the point that it can read Bill's Forth

source code and generates the desired ROM image executable by

MuP21. I am not trying to write a good metacompiler like Bill's,

only one which can metacompile the eForth proper.

OK is first loaded. It is used to assembler the 30 some kernel

words, in the machine code of MuP21. All code words and colon

words are defined such that future references will compile their

addresses in the code dictionary. Numbers are compiled by the

compiler word LIT, strings are compiled by the compiler word $LIT.

Control structures are compiled by the redefined words like

IF, ELSE, THEN, BEGIN, UNTIL, WHILE, REPEAT, AGAIN, etc.

As the eForth is being built, more and more Forth words are

redefined to compile their respective address. In the end, all

words are compiler words, and doing nothing else but compiling.

It become extremely dull, as it will echo 'ok' on any thing you

type and do nothing interesting.

Hence, the ordering of eForth words is very inportant. If you have

to use a function, the corresponding word must be compiled after

all its functions are served.

Memory Map

OK 0-196

Kernel 197-300

TIB 300-350

User Area 3B0-3BF

Data Stack 3C0-3DF

Return Stack 3E0-3FF

Text Utility 400-4FF

Serial Port 500-5FF

Character Table 600-7FF

DOLIST,DOVAR 800-80F

Variables 810-837

User Variables 838-849

Colon Words 84A-BFF

DOLIST,DOVAR C00-C0F

Colon Words C10-FFF

DOLIST,DOVAR 1000-100F

Free Space 1010-19EE

Name Dictionry 19EF-1FFF

Free Memory 2000-AAAA9

Video Buffer AAAAA-B9658

Free Memory B9659-FFFFF

Notice the DOLIST and DOVAR at the beginning of every

1K word page which contains colon definitions and variables.

They are the inner interpreters of colon words and variables

and they allow words to be referenced across page boundaries.

The file INNER.SEQ is loaded at the beginning of every page

used for high level eForth code.

Only 32 words are allocated each for the Data Stack and the

Return Stack. They seem to be quite shallow compared to other

Forth systems. However, 32 words are adequate. While eForth is

running, the water mark of the Return Stack is at 21 words and that

of the Data Stack is at 13. You should feel comfortable with these

stacks. However, don't get carried away and start doing recursion

without relocating the stacks.

Characters and Words

MuP21 is a 20-bit word addressing machine. We can pack 2.5 bytes

to a word, if so desired. However, we take the simpler approach

in assigning one byte to a word. It seems to be quite wasteful,

but we have 1 MB of ROM space and 1M words of DRAM space. So far,

the eForth system uses 2K words for code dictionary and less than

2K words for name dictionary. 1K words are used by OK and the

kernel, and 1K words are used by the character table and service

routines. It occupies the lowest 8K words in the 1M DRAM space.

Within this 8K space, there are still more that 2K words for

dictionary expansion.

C@ and C! are not defined. @ and ! are used in their places.

CELLS, ALIGNED are not needed. CELL+ is 1+ and CELL- is 1-.

A string is a sequence of words preceeded by a 20-bit count. Strings

are therefore not limited to 255 bytes. Theoretically, a string

here can be 1M words long.

B4. Meta28.seq

comment:

meta.seq, meta-compiler for eForth high level words, 04feb95cht

Compile ok21c, okchar21, eforth, and bforth, 11feb96cht

Compile headers in name dictionary, 16feb95cht V2.02

beta version

Update baudRate, !IO, add tv words, 11mar95cht, V2.04

compile ok22c,okchar22, kernel, inner and eforth

Update ok22c, okchar22c, slow down I/O for eForth communication.

Release as V2.06.

Use original 74HC138/74HC245/74HC574 IO chip set.

Replace 14.318 MHz clock by 1.8432 MHz clock for stability in RS232.

Rename files as meta26, ok26c, okchar26.

meta27.seq, include hline27, okchar27, with retchangle, 24nov95cht

meta28.seq, MuP21h with 82C51 serial chip, 14mar96cht

Add RECTANGLE to ok28c.seq, 19mar96cht

comment;

ONLY FORTH ALSO DEFINITIONS

empty HEX WARNING OFF

variable printing?

printing? on

variable debugging?

debugging? off

: .head ( addr -- addr )

printing? @

IF >IN @ 20 word count type space >IN !

dup .

THEN

;

: CR CR

debugging? @

if .s KEY 0D = abort" done"

then

;

' dup alias forthDUP

' drop alias forthDROP

' over alias forthOVER

' swap alias forthSWAP

' @ alias forth@

' ! alias forth!

' and alias forthAND

' + alias forth+

' - alias forth-

' word alias forthWORD

' CR alias CRR

' .( alias forth.(

: 2-OR ROT XOR >R XOR R> ;

: 2AND ROT AND >R AND R> ;

: -OR XOR ;

: ADDRESS C 302 PC! DUP FLIP 301 PC! 300 PC! ;

: DISABLE 7 305 PC! 7 306 PC! ;

: ENABLE 6 305 PC! ;

: 8255 ( n -- ) ( ports A,C output, mode 0)

80 303 PC! ( output )

( C0) 307 PC! ( A,C mode 2, B mode 0 output )

DISABLE ;

C0 8255

ENABLE

: READ 6 306 PC! ;

: WRITE 7 306 PC! ;

: READ-PULSE 4 306 PC! 6 306 PC! ;

: WRITE-PULSE 3 306 PC! 7 306 PC! ;

: ROM@ ( a - b) ADDRESS READ-PULSE

304 PC@ ;

: RAM! ( b a) ADDRESS 304 PC! WRITE-PULSE ;

: CLEAN WRITE 3000 0 DO 0 I RAM! LOOP READ ;

: VIEW ( a) DUP . 10 0 DO CR 10 0 DO DUP ROM@ 3 .R

1 + LOOP LOOP ;

CREATE ram 6000 ALLOT

: RESET ram 6000 ERASE ; RESET

: R@ 3 * ram + DUP 1 + @ FLIP SWAP C@ ;

: R! 3 * ram + SWAP OVER C! SWAP FLIP SWAP 1 + ! ;

: FOUR 4 0 DO DUP R@ AAAAA. 2-OR 6 D.R 1 + LOOP ;

: SHOW ( a) 10 0 DO CR DUP 3 .R SPACE

FOUR SPACE FOUR LOOP ;

: SEND1 WRITE 2000 3FFF DO I AAA -OR ram + C@ I 4000 + RAM!

-1 +LOOP READ ;

: SEND2 WRITE 4000 5FFF DO I AAA -OR ram + C@ I RAM!

-1 +LOOP READ ;

: CHECK1 4000 2000 DO I AAA -OR ram + C@ I 4000 + ROM@ 2DUP -OR IF

CR I 3 .R 4 .R 3 .R ELSE 2DROP THEN LOOP ;

: CHECK2 6000 4000 DO I AAA -OR ram + C@ I ROM@ 2DUP -OR IF

CR I 3 .R 4 .R 3 .R ELSE 2DROP THEN LOOP ;

: SEND WRITE 0 1FFF DO I AAA -OR ram + C@ I RAM!

-1 +LOOP READ send1 send2 ;

: CHECK 2000 0 DO I AAA -OR ram + C@ I ROM@ 2DUP -OR IF

CR I 3 .R 4 .R 3 .R ELSE 2DROP THEN LOOP check1 check2 ;

\ comment:

handle outhcb

: writeROMfile ( writeROMfile <outputfile> <return> )

outhcb !hcb \ ouput file spec

write-only outhcb hopen

IF outhcb hcreate abort" Create file error"

cr ." Create "

ELSE cr ." Update "

THEN

outhcb count type

0.0 outhcb movepointer \ reset file pointer

2000 0 do

I AAA -OR ram +

1 outhcb hwrite

1- abort" write file error"

loop

4000. outhcb movepointer \ skip 8K bytes

6000 4000 do \ this segment in place

I AAA -OR ram +

1 outhcb hwrite

1- abort" write file error"

loop

4000 2000 do \ relocate to 6000-7FFF

I AAA -OR ram +

1 outhcb hwrite

1- abort" write file error"

loop

outhcb hclose abort" Close file error"

;

\ comment;

CR .( include ok28c )

include ok28c

CR .( include hline27 )

include hline27

CR .( include okchar28 )

include okchar28

CR .( include eforth kernel )

include kernel27

comment:

': CLS

:KEY CLSkey BLANK KEY -;'

': redScreen red SCREEN KEY -;'

': blueScreen blue SCREEN KEY -;'

': greenScreen green SCREEN KEY -;'

:KEY TEST MENU greenScreen

ioTest 50dump+ 50dump- emitTest CLSkey keyTest IS !main --

:KEY SELECTION MENU blueScreen

IS !debug -- nibble3 nibble2 nibble1 nibble0 showStacks TEST

!debug fix

:KEY DEBUG MENU redScreen

showStacks goAddress continue repeatAddress -- SELECTION TEST

comment;

\ comment:

SWITCH \ comment out these lines to activate debugger

40001. p PAGE

BLANK

\ comment;

IS !cold

:KEY coldStart

F3E. # 3FF. # nop a!

ljump goAddress

comment:

3FC ORG

F3E. #, 3C0. #, 3E0. #, F3E. #,

SWITCH \ un-comment these two lines to activate debugger

40001. p PAGE

BLANK

comment;

CODE BYE

\ !main FIX

\ ': MAIN MENU 'OK' DEBUG 50dump+ 50dump- coldStart TEST SELECTION RESET

': main menu 'ok' 50dump+ 50dump- \ test1 test2 test3 test4 test5

-- coldStart -- -- reset

SWITCH .

begin .

CR 800 ORG

include inner

CR C00 ORG

include inner

CR 1000 ORG

include inner

: again ( a -- )

BRANCH 0 #, ;

: until ( a -- )

QBRANCH 0 #, ;

: if ( -- a )

QBRANCH begin 0. #, ;

: then ( a -- )

begin 0 AAAAA. 2-or rot R! ;

: else ( a -- a )

BRANCH begin forthSWAP 0. #,

then ;

: while ( a -- a' a )

if forthSWAP ;

: repeat ( a' a -- )

again then ;

: for ( -- a )

>R begin ;

: next ( a -- )

doNEXT 0 #, ;

: aft ( a -- a' a" )

forthDROP BRANCH begin 0. #, begin SWAP ;

: LIT ( d -- )

DOLIT #, ;

: $LIT ( -- )

22 forthWORD count

forthDUP 0 #, ( compile count )

0 DO

count 0 #, ( compile characters )

LOOP

forthDROP ;

' STORE alias !

' AT alias @

' STORE alias C!

' AT alias C@

' (DUP) alias dup

' (SWAP) alias swap

' (DROP) alias drop

' (OVER) alias over

' (AND) alias and

' (XOR) alias xor

' (OR) alias or

' EXIT alias ;;

\ ' WAIT alias ;; \ debugger

: :: makeHead begin .head CONSTANT doLIST DOES> forth@ 0 #, ;

: USER makeHead begin .head CONSTANT doUSER #, DOES> forth@ 0 #, ;

: CREATE makeHead begin .head CONSTANT doVAR DOES> forth@ 0 #, ;

: VARIABLE CREATE ( 0. #,) ; \ let eForth init its variables

.( include eforth28 )

include eforth28

CRR forth.( done compiling ) CRR

B5. ok28c.seq

( EPROM Programmer, Chuck Moore, 1993 Aug 16)

( modified, C. H. Ting, 1993 Nov 23 for mode 2 operations )

( test text display, 3-4-94 cht )

( allot 3000 bytes for ram, include OKCHAR, 3-5-94 cht )

( OKCHAR6.SEQ has text demos, called from TEST. 3-11-94 cht )

( OKCHAR7.SEQ has MuP21.TXT manual demo. 7-16-94 cht )

( OKCHAR8.SEQ has menu captions, 7-17-94 cht )

( OKCHAR10.SEQ blocks of text and demo2, 8-8-94 cht )

( OKCHAR11.SEQ parallel output tests, 8-11-94 cht )

( OK12.seq Bit map display, 9-9-94 cht )

( include OKPICT and compressed pictures, 10-2094 cht )

( OK13.SEQ, 16 pictures, 10-7-94 cht, with OKPICT13.SEQ )

( include OKPICT14 for plastic chips, 01nov94cht )

( OK16.SEQ, add nop before a!, 05nov94cht )

( OK16a.SEQ, sram+text, OK16b.SEQ, sram+picture, OK16c.SEQ, rom+text )

( OK16x.SEQ, experiments with OKCHAR14, rom+text, 06nov94cht )

( Update OK16c.SEQ from OK16x.SEQ, 09nov94cht )

( OK19c.seq, output tests, RS232 interface, 20jan95cht )

( Scrollup in okchar16.seq, 24jan95cht )

( ok20c.seq, with meta.seq, eforth.seq, and bforth, 10feb95cht )

( ok21c.seq, compiled from meta.seq, 11feb95cht )

( ok22c.seq, add rectangle eforth words, 10mar95cht )

( ok26c.seq, slow down I/O, 11nov95cht )

( ok27c.seq, merge rectangle, 24nov95cht )

( ok28c.seq, add RECTANGLE, 19mar96cht )

VARIABLE H

: LOC CONSTANT DOES> @ H ! ;

VOCABULARY 8-B 8-B DEFINITIONS ( 8-bit instructions)

: , ( b) H @ ram + C! 1 H +! ;

: INST CONSTANT DOES> @ , ;

: p 44 , , ;

: # AA -OR p ;

41 INST @+ 45 INST @ 51 INST !+ 55 INST !

80 INST com 81 INST 2* 84 INST 2/ 85 INST +*

90 INST -or 91 INST and 95 INST +

C4 INST dup C5 INST over D4 INST nop D5 INST drop

C0 INST pop C1 INST a D0 INST push D1 INST a!

01 INST ;'

18 INST byte A4D LOC :byte

30 INST word A65 LOC :word

AAA LOC ;reset

3A INST 0a! A6F LOC :0a!

24 INST =0

20 INST jump

22 INST start

:0a! a start ( =0) ;' nop nop nop

( jump) @+ a ( start) =0 jump

:byte 2* 2* 2* 2* 2* 2* 2* 2*

push 00 # -or pop -or ;'

:word byte byte !+ ;'

;reset pop pop dup ( clear stack pointers)

-or a! 0a!

83 p 0E p 0C p word 46 p 0E p 0C p word

55 p AA p 0A p word 21 p 4E p 06 p word

F9 p 4B p 0F p word FC p 0F p 06 p word

55 p 81 p 00 p word 55 p 49 p 08 p word

F9 p 0B p 0F p word 01 p C7 p 0B p word a push

DC p 21 p 06 p word 65 p F5 p 0F p word \ start from AA030

AA p A2 p 0A p word 51 p C1 p 0A p word \ copy 2000 words

FC p 13 p 0B p word 2A p AA p 0A p word ;' \ 11feb95cht

\ header compiler

\ header: | code field | link field | name field |

\ headers are linked backwords and fill name dictionary from hi to low

\ memory, towards the code dictionary.

FORTH DEFINITIONS ( 20-bit instructions)

variable nameH 1FFF nameH ! \ point to next available location

variable lastH 0 lastH ! \ init linkfield address lfa

: nameR! ( n -- )

0 AAAAA. 2-OR nameH @ R! \ store double to code buffer

1 nameH +! \ bump nameH

;

: (makeHead)

20 word \ get name of new definition

dup c@ 2+ negate nameH +! \ compute cfa

H @ nameR! \ fill code pointer field

lastH @ nameR! \ fill link field of last word

nameH @ lastH ! \ save nfa in lastH

dup c@ nameR! \ store count

count 0 do

count nameR! \ fill name field

loop drop

lastH @ 3 - nameH ! \ nameH point to free space

;

: makeHead

>IN @ >R \ save interpreter pointer

(makeHead)

R> >IN ! \ restore word pointer

;

: compile-only 40. lastH @ R@ 2-OR lastH @ R! ;

: immediate 80. lastH @ R@ 2-OR lastH @ R! ;

\ Chuck Moore's P21 20 bit assembler

: 2, , , ;

VARIABLE Hi VARIABLE Hw

: ALIGN 10 Hi ! ;

: ORG DUP . CR H ! ALIGN ;

: SWITCH H @ SWAP ORG ;

: IS H @ Hi @ 10 / + 0 2CONSTANT ;

: ALLOT ( n -- ) H +! ;

CREATE mask AA800. 2, 55400. 2, 32A. 2, D5. 2,

: p, H @ R! 1 H +! ;

: #, AAAAA. 2-OR p, ;

: ,w Hw @ R@ 2-OR Hw @ R! ;

: ,I Hi @ 10 AND IF 0 Hi ! H @ Hw ! 0. p, THEN

Hi @ mask + 2@ 2AND ,w 4 Hi +! ;

: INST 2CONSTANT DOES> 2@ ,I ;

C0280. INST com FF3FC. INST nop

: JMP 2CONSTANT DOES> 2@ BEGIN Hi @ 8 AND WHILE nop REPEAT

,I 3FF AND 155 -OR 0 ,w ALIGN ;

: begin BEGIN Hi @ 10 AND 0= WHILE nop REPEAT H @ ;

: -;' Hw @ R@ OVER 4000 AND IF 4000 ELSE 8000 THEN 0 2-OR Hw @ R! ;

: p 3314C. ,I p, ;

: -p FFFFF. 2-OR p com ;

: # AAAAA. 2-OR p ;

: -# 55555. 2-OR p ;

: FIX DROP 1 - >R begin 0 AAAAA. 2-OR R> R! ;

( bits 10 8 4 2 1: C0280 30140 0C030 0300C 00C03)

00000. JMP jump 0300C. JMP T=0 03C0F. JMP C=0 0C030. JMP call

0300C. JMP until 03C0F. JMP -until

: ': begin .head CONSTANT DOES> @ call ;

: :KEY begin .head CONSTANT DOES> @ 0 #, ;

: CODE makeHead :KEY ; \ for eForth kernel words

: if 155 T=0 Hw @ ;

: -if 155 C=0 Hw @ ;

: skip 155 jump Hw @ ;

: then DUP >R >R begin 3FF AND 155 -OR 0 R> R@ 2-OR R> R! ;

: else skip SWAP then ;

: while if SWAP ;

: -while -if SWAP ;

: repeat jump then ;

30D43. INST @+ ( 33D4F. INST @ ) 3CD73. INST !+ 3FD7F. INST !

C0E83. INST 2* C328C. INST 2/ C3E8F. INST +*

CC2B0. INST -or CCEB3. INST and CFEBF. INST +

F03C0. INST pop F0FC3. INST a F33CC. INST dup F3FCF. INST over

FC3F0. INST push FCFF3. INST a!

00C03. INST ;'

: !!+ dup ! !+ ;

: dup!!+ dup ! dup !+ ;

: , p !!+ ;

: J FFFFF. 2-OR # !!+ ;

: ljump ' >body @ 0 # \ get address of target word

push ;' ; \ long jump

FFFFF. INST drop

33D4F. INST @

( black blue red magenta green cyan yellow white )

( 42108. , 08421. , 10842. , 18C63. , 21084. , 294A5. , 318C6. , 39CE7. , )

: brown 318C6. p ;

: blue 4A529. p ; : red 5294A. p ; : magenta 5AD6B. p ;

: green 6318C. p ; : cyan 6B5AD. p ; : yellow 739CE. p ;

: black 0. p ; : white 7BDEF. p ; : silver 39CE7. p ;

( Boot) 0 ORG

': byte 2* 2* 2* 2*

2* 2* 2* FF. #

@+ and -or ;'

': word' a push nop a! @+

2* byte

a pop nop a! push

!+ pop ;'

( A) ': BOOT A8030. -# com 800. # ( allow 8K addressing space )

begin push word'

pop 80. # nop nop \ copy 8K words

( 10) + -until

( Memory Map)

( Host SRAM DRAM )

( number number pattern number pattern )

( 003 1AA003 C.00AA9 000001 AAAAB DRAM boot )

( 033 1AA033 11 OK code )

( 304 end )

( 330 cos )

( 340 shapes )

( 350 dot masks )

( 36C )

( A45 1AAA45 SRAM boot )

( AAA 1AAAAA C.00000 Reset )

( B98 1AAB98 )

( 100000 8.2AAAA 1000 ABAAA Layout )

( 1B0420 59210 )

( AAAAA 00000 Video image)

( ABDE4 UL corner )

( B9658 )

( IO addresses for development board)

( pattern com )

( 100000 FFFFF slow SRAM )

( 140000 BFFFF fast SRAM )

( 180026 7FFD9 write 8255 control )

( 18000C 7FFF3 read port C )

( 180024 7FFDB write port C )

( 1C0000 3FFFF read fast input port )

( 1C0004 3FFF7 write fast output port )

( 1E0028 1FFD7 write configuration )

( Observations )

( over doesn't work )

( 1 -1 + ripples 3 )

( -1 1 + ripples 9 )

( nop + ripples 19+)

( slot0 + ripples 19+)

80 SWITCH

': BSR 0. p dup !+ !+ ( BBBB)

05FF7. , BDEF7. , ;' ( BSRS SSSS)

': HR ( 18) BSR BDFF7. p BDEF7. p ( SSRS SSSS)

over over !+ !+ over over !+ !+ !+ !+

9DEF7. , 00015. , ( KSSS BBBC)

AD6B5. p ( CCCC)

dup !+ dup !+ !+

AD6A0. , ( CCCB)

0. p ( BBBB)

dup !+ !+ ;'

': H HR A0000. # ( 96)

': Bs begin 0. ,

1000. # nop + -until drop ;'

': Q BSR BDEF7. p dup !+ !+ ( SSSS)

BDC00. , CE000. # Bs ( SSBB)

BSR 9DEF7. , BDEF7. , ( KSSS SSSS)

BDC00. , CE000. # Bs -;' ( SSBB)

': Ss D2000. #

begin BDEF7. , ( SSSS)

1000. # nop + -until

FA000. # Bs -;'

': V BSR BDEF7. , Ss ( SSSS)

BSR 9DEF7. , Ss -;' ( KSSS)

': a+ a nop nop + a! ;'

SWITCH

AAAAA. # nop a!

( AAAAA VR1 21 114* 1+)

Q Q Q V V V Q Q Q

H H H H H H H H H H H H

ABDD2. J

( AB405 VR2 22 114 1+)

HR D9000. # Bs Q Q Q V V V Q Q Q

C7000. # Bs H H H H H H H H H H H H

ABDE6. J

( ABDD2 482 20*) AE37F. # E1E00. # begin HR

push dup com !+ dup !+ 66. # nop +

pop 100. # nop + -until

( AE37A 482 66*) ABDFA. # E2000. # begin 65. # a+

push dup com !+ 14. # nop nop +

pop 100. # nop + -until

65. # a+ AB405. J

65. # a+ AAAAA. J

( BA386)

SWITCH

( 66 1A * = A5C, 14 1A * = 208)

': UL ABFEC. # skip ( 1)

': L2 AC1F4. # skip ( 2)

': LL ADE64. # ( 16)

then then a! @ FFFFF. # -or 8. # nop nop + a! ;'

': 100ms 2. #

': -s

1. #

begin +* -until

drop drop ;'

': KEY? ( n - n) 100ms

\ 70020. ( '245 input )

\ 7FFF3. p com nop a! @ ( port 6 )

7FFFF. p com nop a! @ ( port 0 for new pcb, slow i/o )

\ 3FFFF. p com nop a! @ ( port 0 fast i/o )

55. # -or 7F. # and ;'

:KEY --

': KEY begin KEY? until

IS 'menu 0. # nop a!

begin @+ drop 2/ while repeat

@ push ;'

': MENU 'menu # nop a! pop dup push ! ;'

': PAGE 1FFD7. p com nop a! ! ;'

': -a com a nop nop + nop a! ;'

begin .

100 ORG

dup !+ dup !+ dup !+ dup !+ dup !+ dup !+ dup !+ dup !+

dup !+ dup !+ dup !+ dup !+ dup !+ dup !+

IS 'one dup !+ dup !+

': TWOS !+ skip

begin a push

IS 'twos nop nop IS 'color

0. # TWOS -;'

SWAP then 66. # pop nop nop + nop a!

': HIGH ( 22) 1. # nop nop +

-until drop ;'

': COLOR ( 12) a push 'color # nop a! ! pop nop a! ;'

': WIDE ( 22) a push 'twos # nop a! 2/ 2/ dup 2/ 22065. p nop + !

1. # and if 28860. p

else AA861. p then -or 'one # nop a! !

pop nop a! ;'

': SCREEN

IS 'XY

AE37F. # nop a!

IS 'width

180. # WIDE

IS 'height

1E2. -# HIGH -;'

': BLANK black COLOR SCREEN ;'

CODE RECTANGLE ( x y width height -- )

a push 3. # com

+ dup 3FC. # nop \ SP-4

a! !+ pop !+ \ save new SP, IP and RP

pop ! nop a! \ put SP-3 in A

@+ drop @+ 2/ \ get x and divide it by 4 for an address

2/ @+ dup 2* \ get y and multiply it by 66H

+ 2* dup 2*

2* 2* 2* nop

+ nop nop + \ y*66+x/4

AE37F. # nop nop + \ real screen address

@+ @+ com 'height # \ store negated height

a! ! 'width # nop \ store width

a! ! 'XY # nop \ store screen address

a! !

SCREEN \ draw the rectangle

3FC. # nop a! @+ \ restore new SP, IP, and RP

@+ @ push nop

a! @+ push ;' \ next

': 'OK 80. # WIDE 34. -# HIGH

20. # WIDE 68. -# HIGH

80. # WIDE 34. -# HIGH

3E0F. # -a 20. # WIDE 68. -# HIGH

3E17. # -a 20. # WIDE 4E. -# HIGH

80. # WIDE 34. -# HIGH

20. # WIDE 4E. -# HIGH

52C7. # -a 4E. -# HIGH

14B0. # a+ 4E. -# HIGH -;'

': 'OK' BLANK

08421. p COLOR L2 530. # a+ 'OK

blue COLOR L2 'OK

KEY

:KEY RESET 00000. p PAGE

10. # nop a! BOOT

begin .

B6. hline27.seq

\ hline.seq, draw a horizontal line, 09sep96cht

\ hline26.seq, polishing up, 16sep95cht

\ hline27.seq, merge into eForth2.07, 24nov95cht

\ Use 0F0-0F7 for end masks, 0FC-0FF for parameters, 24nov95cht

comment:

': vline ( height mask color -- , starting addr in A )

over com and push push \ clear unwanted color bits

begin pop pop over @ \ clear color bits in memory

and over -or ! \ add needed pattern bits and store

push push a 66. #

+ nop a! 1. # \ ready A for next line

+ -until \ decrement height until zero

pop pop drop drop drop ;'

comment;

': initHline

\ ': corners ( x1 x2 y1 y2 --, stored in 0FB-0FF, x1,x2,count,ul,colorPtr )

\ reorder x1,x2 and y1,y2 so that x1<x2 and y1<y2

\ if x1>384 quit, clip x2 to 384

\ if y>482 quit

\ store x1 x2 -count ul colorPtr in 0FB-0FF

\ colorPtr points to a 16 word color array, normally at 300

push push over over \ x1 x2 x1 -x2 --

com nop nop +

-if drop push nop a! \ x2>x1, push x2, save x1

else drop nop a! push \ x1>x2, save x2, push x1

then

a dup -180. # nop

+ -if drop drop pop drop \ if x1>384, quit!

pop drop pop ;'

then

drop 0FB. # nop a!

!+ pop dup -180. # \ save x1 in 0FC

+ -if

drop drop 180. # !+ \ if x2>384, replace it by 384

else drop !+ \ save x2 in 0FD

then

pop pop over over \ y1 y2 y1 y2 --

com nop nop +

-if !+ drop \ y1<y2, save y1-y2 as count

else com !+ push drop \ y1>y2, save y2-y1 as count

pop

then \ (lesser of y1 and y2) --

dup -1E2. # nop nop \ test y

+ -if drop drop pop ;' \ y>482, quit!

else drop

then

IS colorPtr

300. # over 7. # and \ pick two color patterns from array

2* -or push dup

2* nop nop + \ 66*y1

2* dup 2* 2*

2* 2* nop nop

+ ( 800.) AE37A. # nop nop \ 66*y+UL

+ !+ pop ! \ save ul and color ptr in 0FE-0FF

': hLine \ draw one horizontal line

\ ': singleCell

0FB. # nop a! @+

@+ over over -or \ get x1 and x2 from 0FC

FFFFC. # and

if \ x1=x2 except 2 lsb's

drop drop \ keep only x1 for leftEnd

else \ no middle section to show

drop dup 2/ 2/ \ x1 x2 x2/4 --

@+ over nop nop \ x1 x2 x2/4 ul x2/4 --

+ push 1. # and \ x1 x2 LSB(x2/4) --

@ nop nop + \ x1 x2 colorPtr --; R: addr --

a! @ push push \ x1 x2 --; R: addr color x2 --

3. # and 0F0. # -or \ addr(x1mask) --

a! @ pop 3. # \ x1mask x2 3 --

and 0F4. # -or nop \ x1mask addr(x2mask) --

a! @ and pop \ mask color --

pop nop a! over \ mask color mask --; addr in A

and push com @ \ /mask mem --

and pop -or ! \ --

pop ;'

then

\ ': leftEnd ( x1 -- )

dup 3. # and 0F0. #

+ nop a! @ \ x1 mask --

push 2/ 2/ 0FE. # \ x1/4 0FE --

a! @+ over nop \ x1/4 ul x1/4 --

+ push 1. # and \ (x1/4)and1 --; R: mask addr --

@ nop + nop \ colorPtr --

a! @ pop nop \ color addr -- ; R: mask --

a! pop dup push \ mask color bits

and @ pop com \ mask mem bits

and -or !+ \ write new mem bits to memory

\ ': middle ( -- )

a push 0FB. # nop \ R: x1addr --

a! @+ FFFFC. # and \ strip off ls 2 bits from x1

@+ com nop nop \ x1 -x2 --

+ 4. # nop nop \ discard count

+ @+ drop @+ \ discard ul

drop @ nop a! \ x1-x2+1 --; colorPtr in A

pop dup push 1. # \ x1-x2 x1addr -- ; R: x1addr --

and if \ from x1addr determine color order

@+ push @ pop \ x1-x2 color2 color1 --

else @+ @ \ x1-x2 color1 coler2 --

then

\ push push drop 0F0. # \ x1-x2+1 0F0. --; R: x1addr col col --

\ a! dup !+ pop \ dump stack for debugging

\ dup !+ pop dup

\ !+ pop dup !

\ push push push nop

push push drop nop

a! pop pop a

pop nop a! \ color1 color2 x1-x2+1 x1addr --

\ x1addr is now in A

begin \ color1 color2 count --, x1addr in A

8. # nop nop +

-while

push over !+ dup \ write 2 words at a time

!+ pop

repeat

4. # and

if drop drop drop \ write odd word

else drop drop !+

then

\ ': rightEnd ( --, A has memory address )

a push 0FC. # nop \ 0FD. --; R: x2addr --

a! @+ @+ drop \ x2 --

@+ drop nop nop \ discard counts and ul

@ pop dup push \ x2 colorPtr x2/4 --

1. # and nop + \ x2 colorPtr' --

a! @ over 3. # \ x2 color x2 3

and 0F4. # nop + \ x2 color maskAddr --

a! @ dup push \ x2 color mask --

and pop pop nop \ x2 color.mask mask x2addr --

a! com @ and \ x2 color.mask mem/mask --

-or ! drop ;'

CODE RECT ( x1 x2 y1 y2 -- )

a push 3. # com

+ 3FC. # nop a!

dup !+ pop !+ \ save SP, IP, and RP in this order

pop ! nop a!

@+ drop @+ @+ \ fetch x1, x2, y1, and y2 from DS

@+ @

initHline \ prepare data in 0FB-0FF

begin

hLine \ write one line

0FD. # nop a! @ \ increment count

1. # nop nop +

-if drop 3FC. # nop a! \ overflow, restore SP, IP and RP

@+ @+ @ push

a! @ push ;' \ rectangle completed. exit

else !+ @ 66. # nop \ store bumped count

+ !+ @ 2. # \ add 66 to ul

+ 30F. # and ! \ add 2 to colorPtr

then

jump \ repeat

CODE SetColor ( color -- ) \ set color in 8x8 pattern array

a push dup a! \ save IP

@ 7BDEF. # and \ get color from DS

300. # nop a! 10. # \ init shift-counter to do 16 loops

begin over !+ 2* \ write pattern, bump counter

-until

drop dup -or com \ decrement SP

+ pop nop a! \ restore IP and do next

@+ push ;'

comment:

:KEY newColor ( -- )

IS 'newColor \ where new pattern comes from

0. # nop a! 300. # \ source in A, ( dest 10 -- )

10. #

begin

push push @+ 7BDEF. # \ dest pattern --

and AAAAA. # -or a \ dest --, R: count pattern source --

pop nop a! push \ dest in A, store pattern, source --

!+ a pop nop \ source in A

a! pop 2* \ dest count*2 --

-until

drop drop a 'newColor # \ preserve newColor for next time

a! !

0. # 17F. # over 1E0. # \ plot screen with new pattern

rectangle

KEY

comment;

begin 300 org \ color as patterns

7BDEF. p, 7BDEF. p, 7BDEF. p, 7BDEF. p,

0F0 org

7BDEF. #, 03DEF. #, 001EF. #, 0000F. #,

78000. #, 7BC00. #, 7BDE0. #, 7BDEF. #,

ORG

begin .

B7. okchar28.seq

\ Text utility for MuP21, 05mar94cht

\ Save return stack in character. 06mar94cht

\ TextLine ok. 07marcht okchar3.seq

\ Foreground background colors, 07mar94cht okchar4.seq

\ Use 'screen to store screen address, 09mar94cht

\ Use 'pattern to store pattern address, 09mar94cht

\ Preliminary ASCII dump using number, 09mar94cht okchar5.seq

\ ASCII dumps and character set demos. 11mar94cht okchar6.seq

\ Integrated to ok4.seq

\ Interface to an Apple II keyboard. 20apr94cht

\ Display text blocks, 13jul94cht okchar7.seq

\ Display captions, 17jul94cht okchar10.seq

\ Display pictures, 10sep94cht okchar12.seq

\ Display compressed picture, 25sep94cht

\ okpict.seq, decompression in P21

\ okcomprs.seq, compress .bmp to .p21

\ picture.seq, write .p21 file to sram

\ Replace inline code with count loops, 25oct94cht

\ Optimize nibble routines, reduce stack depth, 29oct94cht, okchar14.seq

\ prevent hickup in nibble, 30oct94cht

\ okchar19, add scrollUp, 24jan95cht

\ okchar20, inproved baudRate, 100us, and 50us, 10feb95cht

\ okchar21, ?RX, TX!, and !IO, 17feb95cht

\ okchar22, add text word set, rewrite 100us and baudRate, 08mar95cht

\ okchar26, use slow I/O ports for RS232 stability, 11nov95cht

\ okchar28, MuP21h with 82C51, 14mar96cht

begin

400 ORG

( 16 patterns for 16 nibbles )

00000. #, 0000F. #, 001E0. #, 001EF. #,

03C00. #, 03C0F. #, 03DE0. #, 03DEF. #,

78000. #, 7800F. #, 781E0. #, 781EF. #,

7BC00. #, 7BC0F. #, 7BDE0. #, 7BDEF. #,

00000. #, 00000. #, 00000. #, 00000. #, ( for blank underline )

00000. #, 00000. #, 00000. #, 00000. #, ( save return stack in 414-417 )

00000. #, ( save screen address )

420 ORG

( color table )

00000. #, 08421. #, 10842. #, 18C63. #,

21084. #, 294A5. #, 318C6. #, 39CE7. #,

42108. #, 4A529. #, 5294A. #, 5AD6B. #,

6318C. #, 6B5AD. #, 739CE. #, 7BDEF. #,

': nibble ( 'nibble has pattern, will be divided by 16 )

( 'screen has screen address, stack depth=3 )

IS 'nibble \ avoid pass it on the stack, 10/29/94

0. # 0F. # and 400. # \ get pattern addres

-or nop a! @ dup a! \ get pattern

IS 'foreground

7BDEF. # and a com \ get foreground color

IS 'background

0. # and -or \ add background color

AAAAA. # -or \ convert to screen pattern

IS 'screen

3F0. # a! \ get screen address

dup ! a \ write to screen

66. # nop nop + \ get next line address

nop a! !+ \ write to next line

a -66. # nop +

'screen # nop a! ! \ save screen address

'nibble # nop a! @ \ update 'nibble

2/ 2/ 2/ 2/ \ shift to next nibble

! ;'

': setForeground ( color# -- )

0F. # and 420. # -or \ get color from color table

a! @

': foreground ( color -- )

'foreground # nop a! ! ;'

': setBackground ( color# -- )

0F. # and 420. # -or \ get color from color table

a! @

': background ( color -- )

'background # nop a! ! ;'

': 2nibbles ( -- ) \ write out two nibbles on two lines

nibble nibble \ write out two nibbles

'screen # nop a! @ CA. # \ skip one line

nop nop + ! ;' \ move to next screen line

': 4nibbles ( --, stack depth=3 )

IS 'pattern

600. # nop a! @+ \ get a character pattern word

a 'pattern # nop a! ! \ save pattern address

'nibble # nop a! ! \ store dot pattern

2nibbles \ write 1st two lines

2nibbles -;' \ repeat 2nd line

': character ( -- , stack depth=3 )

414. # nop a! pop !+ \ save R

pop !+ pop !+ pop ! \ save R, R1-3

IS 'character

0. # 7F. # \ get character and use only 7 bits

and 2* 2* 600. # \ n*4, offset into char table

-or 'pattern # nop a! ! \ add offset to char table

4nibbles \ output 4 nibbles

4nibbles \ output one nibble from 2nd pattern

4nibbles \ output 3rd pattern

4nibbles \ output 4th pattern

'pattern # nop a! 600. # ! \ null pattern

4nibbles \ output underline

'screen # nop a! @ -7F6. # \ move screen address to next character

nop nop + ! nop nop \ in the same character line

417. # a! @ push

416. # a! @ push

415. # a! @ push

414. # a! @ push

': showCharacter ( char -- )

'character # nop a! !

character

-;'

': textLine ( n -- ) \ 32 text lines of 40 characters

push FF00. # pop nop \ 7F8=20 scan lines

+* 2/ nop nop \ 7F8*n

+* 2/ nop nop

+* 2/ AEDE2. # nop \ UL. AE37A+A5C+C

nop + 'screen # nop a!

! drop ;' \ save in 'screen

': digit ( -- )

IS 'number \ where number is to be printed

AC008. # 0F. # and dup \ retain only the last nibble

9. -# nop nop + \ is it less then 10?

-if

drop 37. # \ yes, make it a digit

else

drop 30. # \ no, make it A-F

then

+ showCharacter \ print to screen

'screen # nop a! @ \ backup character pointer

3. -# nop nop + !

'number # nop a! @ \ divide number by 16

2/ 2/ 2/ 2/ \ get next nibble in 'number

! ;' \ store number

': number ( n -- )

'number # nop a! ! \ store number into 'number in digit

digit digit \ print nibbles from right to left

digit digit digit

'screen # nop a! @ 16. # \ space to next number field

nop nop + ! ;'

': 4dump \ dump 4 consecutive locations

IS 'row#

0. # textLine

'screen # nop a! @ 10. #

nop nop + !

IS 'address

0. # number

'address # nop a! @

a! @ number

'address # nop a! @

1. # + nop a!

@ number

'address # nop a! @

2. # + nop a!

@ number

'address # nop a! @

3. # + nop a!

@ number

'address # nop a! @

4. # nop nop + !

'row# # nop a! @

1. # nop nop +

! ;'

:KEY 50dump- \ dump 80 locations backward

FFF60. # 'address # nop a! @

nop nop + !

:KEY 50dump+ \ dump 80 locations foreward

': 50dump

0. # 'row# # nop a! !

1. #

begin 4dump

2* -until

drop

ljump KEY

': 25us ( 1/2 bit delay )

8. # skip

': 100us ( 1 bit delay in serial I/O )

2. # ( 100 us is about 1 bit at 9600 baud )

then

IS 'speed

-3FF. # ( 256 cycles for 50us, 512 for 100us )

begin +* nop -until

drop drop ;' ( restore IO port in A )

CODE SLOW ( -- , reduce jitter in video )

a push 'speed # nop

a! -FFFF. # ! pop

nop a! @+ push

CODE FAST ( -- , for file downloading )

a push 'speed # nop

a! -3FF. # ! pop

nop a! @+ push

CODE !IO ( initialize 82C51 )

a push ( save IP on S, SP IP -- )

7FFFC. p com nop a! ( slow I/O port, SP IP addr -- )

0. p ! 25us ( 3 default 0's to init 80C51 )

0. p ! 25us

40. p ! 25us ( reset )

CE. p ! 25us ( 16x, 8 data bits, 2 stop bits, no parity)

27. p ! 25us ( enable Tx, Rx, /DTR, /RTS )

pop nop a! ( restore IP and SP )

@+ push ;' ( next )

comment:

:KEY ioTest

7FFFC. p com nop a! ( slow I/O port, SP IP addr -- )

0. p ! 25us ( 3 default 0's to init 80C51 )

0. p ! 25us

40. p ! 25us ( reset )

CD. p ! 25us ( 1x, 8 data bits, 2 stop bits, no parity)

27. p ! 25us ( enable Tx, Rx, /DTR, /RTS )

ljump KEY

comment;

CODE ?RX ( -- c true | false, get character )

25us

a push ( save IP )

7FFFD. p com nop a! ( slow status port in 82C51 )

comment:

@ AA. # -or 38. # and ( any error? )

if drop nop a! @+ ( yes, push false on data stack )

dup -or ! a

7FFFC. p com nop a! ( clear error )

37. p !

pop nop a!

@+ push ;' ( return with a false flag )

else drop ( no error, continue )

then

comment;

@ com 2. # and ( RxRDY? )

if 7FFFF. p com nop a! ( read character from 82C51 )

drop @ AA. # -or

FF. # and push nop ( get SP into A )

a! @+ drop pop ( bump SP and push character )

!+ -1. # ! ( push -1 flag )

else push nop a! @+ ( else push false flag on data stack )

drop pop !

then

a pop nop a! ( restore SP and IP )

@+ push ;' ( next )

comment:

:KEY keyTest

10. # textLine

7FFFD. p com dup a! ( slow status port in 82C51 )

begin

drop 25us

@ com 2. # and ( RxRDY? )

until

7FFFF. p com nop a! ( read character from 82C51 )

drop @ AA. # -or

FF. # and ( get SP into A )

showCharacter

ljump KEY

comment;

CODE TX! ( c -- )

a push

7FFFD. p com dup a! ( status port in 82C51 )

begin

100us

drop @ 4. # and ( wait for TxEmpty )

until

drop dup nop a! ( save IP on RS, put SP in A )

@ AA. # -or nop

7FFFE. p com nop a!

! dup dup -or ( data output port in 82C51 )

com nop nop + ( send character out )

pop nop a! ( decrement S, restore I )

@+ push ;' ( next )

comment:

:KEY emitTest

7FFFE. p com nop a! ( status port in 82C51 )

42. p !

ljump KEY

comment;

\ comment:

': move20words ( source in A, dest on stack, a -- a' )

push 1. # \ save dest, introduce count

begin

@+ pop a push \ get data, exchange source and dest

a! !+ pop a \ store data, exchange source and dest

push nop a!

2* -until

drop pop ;' \ restore destination

': scrollUp ( -- )

AEDE2. 7F8. D+ # nop a! \ init source

AEDE2. # \ init destination

E8400. # \ move 19x20 scan lines

begin push

move20words \ copy 80 words of a line

move20words

a 16. # nop nop \ move source to next line

+ nop a! 16. # \ move dest to next line

+ pop 100. # nop \ loop 320 lines

+ -until

drop drop ;'

CODE FG ( color# -- )

a push dup a! \ get SP

@ 0F. # and 420. #

-or nop a! @ \ get color

dup 'foreground # nop a! \ put in 'foreground for characters

! AAAAA. # -or 'color #

a! ! pop nop \ also put in 'color for SCREEN

a! dup dup -or \ restore IP, decrement SP

com nop nop +

@+ push ;'

CODE BG ( color# -- )

a push dup a! \ get SP

@ 0F. # and 420. #

-or nop a! @ \ get color

dup AAAAA. # -or nop

'background # nop a! ! \ put in 'background for characters

'color # nop a! ! \ also put in 'color for SCREEN

pop nop a! dup \ restore IP, decrement SP

dup -or com nop

+ @+ push ;' \ next

CODE tvAT ( x y -- ) \ convert character coordinates to 'screen

a 3FC. # nop a!

!+ pop !+ dup

dup -or com nop

+ dup ! nop

a! @+ @

textLine

2* 'screen # nop a! \ add 2x to 'screen

@ nop + !

3FC. # nop a! @+

@+ push push @

pop nop a! dup

dup -or com nop

+ @+ push ;' \ next

CODE tvEMIT ( char -- )

a 3FC. # nop a!

!+ pop !+ dup

! nop a! @

showCharacter

3FC. # nop a! @+

@+ push push @

pop nop a! dup

dup -or com nop

+ @+ push ;' \ next

CODE tvCR

a 3FC. # nop a!

!+ pop !+ ! \ save IP, RP, SP

scrollUp

12. # textLine

3FC. # nop a! @+

@+ push push @

pop nop a!

@+ push ;'

\ comment;

begin .

600 ORG ( character table )

0000. #, 0000. #, 0000. #, 0000. #, 24C3. #, 185A. #, 24DB. #, 00C3. #,

E7C3. #, FFBD. #, E73C. #, 00C3. #, EE00. #, EFEF. #, 83C7. #, 0001. #,

8301. #, EFC7. #, 83C7. #, 0001. #, C300. #, FF81. #, 80FF. #, 0081. #,

8301. #, EFC7. #, 01EF. #, 0083. #, 0000. #, C381. #, 0081. #, 0000. #,

FFFF. #, 3C7E. #, FF7E. #, FFFF. #, C300. #, 1824. #, 2418. #, 00C3. #,

3CFF. #, E7DB. #, DBE7. #, FF3C. #, 70F1. #, C7D0. #, 6C6C. #, 00C7. #,

E700. #, 3C3C. #, 81E7. #, 81E7. #, 6040. #, 4070. #, CF40. #, 008F. #,

A0C0. #, B0D0. #, 9F9F. #, F1F1. #, 2900. #, 44C7. #, C76C. #, 0029. #,

0000. #, 8706. #, 87E7. #, 0006. #, 0000. #, E160. #, E1E7. #, 0060. #,

E781. #, 8181. #, 8181. #, 81E7. #, 6666. #, 6666. #, 0066. #, 0066. #,

6BFF. #, 6367. #, 6363. #, 0063. #, 1CE7. #, 22CD. #, F122. #, E738. #,

0000. #, E700. #, 00E7. #, 0000. #, E781. #, 8181. #, 81E7. #, FF00. #,

E781. #, 8181. #, 8181. #, 0081. #, 8181. #, 8181. #, E781. #, 0081. #,

4000. #, FF60. #, 4060. #, 0000. #, 0200. #, FF06. #, 0206. #, 0000. #,

0000. #, 0C00. #, 0C0C. #, 00FF. #, 4200. #, FF66. #, 4266. #, 0000. #,

0000. #, 8301. #, EFC7. #, 0000. #, 0000. #, EF00. #, 83C7. #, 0001. #,

0000. #, 0000. #, 0000. #, 0000. #, 0303. #, 0303. #, 0003. #, 0003. #,

6666. #, 0000. #, 0000. #, 0000. #, C6C6. #, C6EF. #, C6EF. #, 00C6. #,

C701. #, C72D. #, C768. #, 0001. #, 690F. #, 81CF. #, 27E3. #, 00ED. #,

8403. #, 8703. #, CCEC. #, 0087. #, C0C0. #, 0081. #, 0000. #, 0000. #,

0601. #, 0C0C. #, 060C. #, 0001. #, C001. #, 6060. #, C060. #, 0001. #,

4500. #, EF83. #, 4583. #, 0000. #, 8100. #, E781. #, 8181. #, 0000. #,

0000. #, 0000. #, 0000. #, 0781. #, 0000. #, E700. #, 0000. #, 0000. #,

0000. #, 0000. #, 0000. #, 0081. #, 6020. #, 81C0. #, 0603. #, 000C. #,

ECC7. #, 6FED. #, 6E6E. #, 00C7. #, 8381. #, 8187. #, 8181. #, 00C3. #,

6CC7. #, C060. #, 0603. #, 00EF. #, 6CC7. #, C360. #, 6C60. #, 00C7. #,

E1E0. #, 6663. #, 60EF. #, 0060. #, 0CEF. #, CF0C. #, 6060. #, 00CF. #,

6CC7. #, CF0C. #, 6C6C. #, 00C7. #, 60EF. #, 81C0. #, 0603. #, 0006. #,

6CC7. #, C76C. #, 6C6C. #, 00C7. #, 6CC7. #, E76C. #, 6C60. #, 00C7. #,

0300. #, 0000. #, 0300. #, 0000. #, 0300. #, 0000. #, 0300. #, 0002. #,

C100. #, 0603. #, C103. #, 0000. #, 0000. #, 00E7. #, 00E7. #, 0000. #,

0700. #, C081. #, 0781. #, 0000. #, 6CC7. #, 81C0. #, 0003. #, 0003. #,

28C7. #, AAA9. #, E9AA. #, 00C7. #, 6CC7. #, EF6C. #, 6C6C. #, 006C. #,

66CF. #, C766. #, 6666. #, 00CF. #, 6CC7. #, 0C0C. #, 6C0C. #, 00C7. #,

66CF. #, 6666. #, 6666. #, 00CF. #, 26EF. #, 8786. #, 2686. #, 00EF. #,

26EF. #, 8786. #, 0686. #, 000F. #, 6CC7. #, 0C6C. #, 6CED. #, 00C7. #,

6C6C. #, EF6C. #, 6C6C. #, 006C. #, 81C3. #, 8181. #, 8181. #, 00C3. #,

C0E1. #, C0C0. #, CCC0. #, 0087. #, CC6C. #, 0F8D. #, CC8D. #, 006C. #,

060F. #, 0606. #, 2606. #, 00EF. #, EE6C. #, 6DEF. #, 6C6C. #, 006C. #,

6E6C. #, ED6F. #, 6CEC. #, 006C. #, 6CC7. #, 6C6C. #, 6C6C. #, 00C7. #,

66CF. #, C766. #, 0606. #, 000F. #, 6CC7. #, 6C6C. #, 6C6C. #, C0C7. #,

66CF. #, C766. #, 6666. #, 006E. #, 6CC7. #, C70C. #, 6C60. #, 00C7. #,

A5E7. #, 8181. #, 8181. #, 00C3. #, 6C6C. #, 6C6C. #, 6C6C. #, 00C7. #,

6C6C. #, 6C6C. #, C66C. #, 0083. #, 6C6C. #, 6C6C. #, EE6D. #, 006C. #,

C66C. #, 8383. #, C683. #, 006C. #, 6666. #, C366. #, 8181. #, 00C3. #,

6CEF. #, 81C0. #, 6603. #, 00EF. #, 81C1. #, 8181. #, 8181. #, 00C1. #,

060C. #, 8103. #, 60C0. #, 0020. #, 0307. #, 0303. #, 0303. #, 0007. #,

0000. #, 8301. #, 6CC6. #, 0000. #, 0000. #, 0000. #, 0000. #, FF00. #,

0303. #, 0081. #, 0000. #, 0000. #, 0000. #, 60C7. #, 6CE7. #, 00E7. #,

0C0C. #, 6CCF. #, 6C6C. #, 00CF. #, 0000. #, 6CC7. #, 6C0C. #, 00C7. #,

6060. #, 6CE7. #, 6C6C. #, 00E7. #, 0000. #, 6CC7. #, 0CEF. #, 00C7. #,

66C3. #, 0F06. #, 0606. #, 0006. #, 0000. #, 6CE7. #, E76C. #, C760. #,

0C0C. #, 6CCF. #, 6C6C. #, 006C. #, 0081. #, 8183. #, 8181. #, 00C3. #,

C000. #, C100. #, C0C0. #, 87CC. #, 0C0C. #, 8D6C. #, 8D0F. #, 006C. #,

8183. #, 8181. #, 8181. #, 00C3. #, 0000. #, EFEE. #, 6C6D. #, 006C. #,

0000. #, 6CCF. #, 6C6C. #, 006C. #, 0000. #, 6CC7. #, 6C6C. #, 00C7. #,

0000. #, 6CCF. #, CF6C. #, 0C0C. #, 0000. #, 6CE7. #, E76C. #, 6060. #,

0000. #, 67ED. #, 0606. #, 0006. #, 0000. #, 0CC7. #, 60C7. #, 00C7. #,

8181. #, 81E7. #, 8181. #, 00E1. #, 0000. #, 6C6C. #, 6C6C. #, 00E7. #,

0000. #, 6C6C. #, C66C. #, 0083. #, 0000. #, 6C6C. #, EF6D. #, 006C. #,

0000. #, C66C. #, C683. #, 006C. #, 0000. #, 6C6C. #, E76C. #, C760. #,

0000. #, C0EF. #, 0681. #, 00EF. #, 81E0. #, 0781. #, 8181. #, 00E0. #,

8181. #, 0081. #, 8181. #, 0081. #, 030E. #, C103. #, 0303. #, 000E. #,

0000. #, A907. #, 00E0. #, 0000. #, 0000. #, C381. #, FF66. #, 0000. #,

ORG

B8. kernel27.seq

\ eForth Kernel for MuP21, 21mar94cht

\ eforth1.seq, update for plastic chip, 03feb95cht

\ kernel27.seq, comment out debugging aids, 24nov95cht

\ Keep 0 page usage to 2FF. 300-3FF needed by system.

comment:

The Forth Virtual Engine is:

I IP A register Instruction pointer

S SP T register Data stack pointer

R RP R register Return stack pointer

Both the data and return stacks are in external memory. The

registers R1-R3, and S1-S5 are free. The three registers A, T

and R form a very powerful cluster to support a Forth Virtual

Engine.

A register is used to host IP because it leads to the most

efficient $next:

@+ push ;

To address data stack, one can exchange S and I by

a push a! pop or push a pop a!

To address return stack, one can exchange R and I by

a pop a! push or pop a push a!

Because A register has the self-incrementing feature, stacks

can be addressed conveniently towards the high memory. It is

thus chosen that the stacks grow towards high memory. To pop

items off the stack, the stack pointer must be decremented

explicitly.

Names of words are in a separated head dictionary. Only executable

code are in the code dictionary. High level words are also in a

separated segment of memory. Code words, stacks, and user variables

must be in one 1K page for best performance.

Memory allocation:

0 Boot code

400 Screen and keyboard drivers

600 Character table

800 Code words

B00 User variables

BB0 Return stack, for dump

BD0 Data stack

BF0 Test code

BFC Saved SP, IP, RP, R1

C00 Colon words

1000 Headers

2000 Free space

comment;

CR .( kernel words ) CR

hex

comment:

?RX TX! IO! are defined in okchar20.seq

CODE ?RX

CODE TX!

CODE !IO

comment;

CODE doLIT

@+ a push push \ get literal, save it and I

a! pop @+ drop \ increment S for pushing

! a pop nop \ push literal on stack, restore I

a! @+ push ;' \ $next

CODE EXIT \ undo nest

pop nop a! @ \ get new I from return stack

a dup dup -or \ make -1

com nop nop + \ decrement return stack pointer

push nop a! @+ \ restore R, get new I

push ;' \ return

CODE EXECUTE ( a )

push a pop nop \ exchange S and I

a! @ push push \ push address, restore I

a pop nop a! \ decrement S to top address

dup dup -or com

+ ;' \ return jumps to address

CODE BRANCH

@+ nop a! @+ \ get inline target address to I

push ;' \ go there

CODE QBRANCH ( f )

push a pop nop \ exchange S and I

a! @ push push \ get f and save it

a pop nop a! \ restore S and I, get f

pop if

@+ drop \ f is true, skip branch address

else @+ nop a! \ f is false, get address to jump

then

dup -or com nop \ pop f off stack

+ @+ push ;' \ $NEXT

CODE doNEXT

pop a push nop \ exchange R and I

a! @ -1. # nop \ decrement count

+ -if \ if carry set, continue looping

! pop a push \ store back decremented count

a! @+ nop a! \ get loop address into A

else \ carry not set, count must be 0

dup -or com a \ pop count off return stack

+ pop nop a! \ jump over loop address

push @+ drop \ by a dummy @+

then \ A has the proper address of next inst

@+ push ;' \ go for it

(makeHead) !

:KEY STORE ( n a -- )

dup dup -or com

+ a push dup \ save I, point S to n

a! @+ @ nop \ get n and a

a! ! dup dup \ store n to a, point S to next item

-or com nop nop

+ pop nop a! \ restore I

@+ push ;' \ $NEXT

(makeHead) @

:KEY AT ( a - n )

a push dup nop \ save I, move S to A

a! @ nop a! \ get data

@ push dup a! \ store data on stack

pop ! pop nop \ restore I

a! @+ push ;' \ $NEXT

CODE RP@ ( - a )

push a pop nop \ exchange S and I

a! @+ drop pop \ increment S, get R

dup ! push push \ push R on stack, restore R

a pop nop a! \ restore I

@+ push ;' \ $NEXT

CODE RP! ( a )

push a pop nop \ exchange S and I

a! @ pop drop \ replace R with a

push push a pop \ restore I

a! dup dup -or \ decrement S

com nop nop +

@+ push ;' \ $NEXT

CODE R> ( - n )

pop a push nop \ exchange R and I

a! @ pop a \ get n from return stack

dup dup -or com \ -1

+ push a! push \ decrement R, push n

push a pop nop \ exchange S and I

a! @+ drop pop \ increment S, push n on stack

! push a pop \ restore I and S

a! @+ push ;' \ $NEXT

CODE R@ ( - n )

pop a push nop \ exchange R and I

a! @ pop a push \ get n from top of R

a! push push a \ push n, exchange S and I

pop nop a! @+ \ increment S, get n

drop pop ! push \ push n on S, restore I and S

a pop nop a!

@+ push ;' \ $NEXT

CODE >R ( n )

push a pop nop \ exchange S and I

a! @ push push \ get and save n

a pop nop a! \ restore S and I

pop pop a push \ exchange R and I, increment R

a! @+ drop ! \ push n on R, restore R

pop a push nop \ restore I

a! dup dup -or

com nop nop + \ decrement S

@+ push ;' \ $NEXT

CODE SP@ ( - n )

push a pop dup \ exchange S and I, save extra S

a! @+ drop ! \ increment S, push SP on stack

push a pop nop \ restore S and I

a! @+ push ;' \ $NEXT

CODE SP! ( n )

push a pop nop \ exchange S and I

a! @ push nop

a! pop \ get new SP and restore I

@+ push ;'

(makeHead) DROP

:KEY (DROP) ( n )

dup dup -or com \ decrement S

+ @+ push ;'

(makeHead) DUP

:KEY (DUP) ( n - n n )

push a pop nop \ exchange S and I

a! @+ ! push \ push n on stack

a pop nop a! \ restore S and I

@+ push ;' \ $NEXT

(makeHead) SWAP

:KEY (SWAP) ( n1 n2 - n2 n1 )

dup dup -or com \ S-1

+ push a pop \ save I, get S-1 to A

dup a! @+ @ \ get n1

push push nop a! \ get n2, save them, get S-1 to A again

pop pop !+ ! \ push n2 and then n1 on stack

push a pop nop \ restore S and I

a! @+ push ;' \ $NEXT

(makeHead) OVER

:KEY (OVER) ( n1 n2 - n1 n2 n1 )

dup dup -or com \ S-1

+ push a pop \ save I, get S-1 to A

a! @+ @+ drop \ get n1, increment S twice

\ push n1 on stack

! push a pop \ restore S and I

a! @+ push ;' \ $NEXT

CODE 0< ( n - f )

push a pop nop \ exchange S and I

a! @ 2* dup \ get n, test negativeness

-if -or com \ if negative, push -1

else -or then \ if positive, push 0

! push a pop

a! @+ push ;'

(makeHead) AND

:KEY (AND) ( n n - n )

dup dup -or com \ generate -1 with carry

+ push a pop \ save I, decrement S

dup a! @+ @ \ get two item off data stack

and push nop a! \ AND them and push back on stack

pop ! push a \ restore S and I

pop nop a!

@+ push ;'

(makeHead) OR

:KEY (OR) ( n n - n )

dup dup -or com \ generate -1 with carry

+ push a pop \ save I, decrement S

dup a! @+ com \ get two item off data stack

@ com and com \ OR=NOT(NAND)

push nop a! pop \ OR them and push back on stack

! push a pop \ restore S and I

a! @+ push ;'

(makeHead) XOR

:KEY (XOR) ( n n - n )

dup dup -or com \ generate -1 with carry

+ push a pop \ save I, decrement S

dup a! @+ @ \ get two item off data stack

-or push nop a! \ XOR them and push back on stack

pop ! push a \ restore S and I

pop nop a!

@+ push ;'

CODE UM+ ( n n - n carry )

dup dup -or com \ generate -1 with carry

+ push a pop \ save I, decrement S

dup a! @+ @ \ get two item off data stack

+ -if 1. # \ add, get carry

else dup dup -or

then

push push nop a! \ push carry and sum back on stack

pop !+ pop !

push a pop nop \ restore S and I

a! @+ push ;'

comment:

CR .( debugging words ) CR

:KEY WAIT \ save IP, SP and RP

a 3FC. # nop a! \ get IP, init A to 3FC

!+ !+ pop !+ \ save IP, SP, and RP

:KEY showStacks

': displayStacks

3B0. # 'address # nop

a! ! \ set dump address

ljump 50dump \ display stacks and registers

:KEY CONTINUE

3FD. # nop a! @+ \ restore SP, RP

@+ dup nop a! \ move RP to A, ready to pop IP

dup dup -or com \ make -1

+ push @ nop \ decrement RP, push in place

a! @+ push ;' \ get new IP, ready for next word

:KEY nibble0 \ increment nibble 0 in 3FF

0F. # skip

:KEY nibble1 \ increment nibble 1 in 3FF

F0. # skip

:KEY nibble2 \ increment nibble 2 in 3FF

F00. # skip

:KEY nibble3 \ increment nibble 3 in 3FF

F000. # skip

:KEY nibble4 \ increment nibble 4 in 3FF

F0000. #

then then then then

dup dup dup push \ n n n -- , another save in R

IS 'modified

3FF. # nop a! @ \ get address in 3FF

and + and \ add -1 to selected nibble

pop com @ and -or \ merge nibble with address

! \ modify it and store back

displayStacks -;' \ show results

:KEY repeatAddress \ repeat executing address in 3FF

3FD. # nop a! @+ \ restore SP and RP from 3FD, 3FE

@+ push 3FF. # nop \ get address into A

a! @ nop a!

@+ push ;' \ repeat

comment;

:KEY goADDRESS \ jump to address in 3FF

3FF. # nop a! @ \ copy address into A

a! 3C0. # 3E0. # push \ init SP and RP

@+ push ;' \ go

begin .

B9. inner.seq

\ inner.seq, inner interpreter, 17feb95cht

CRR

\ doLIST must be at the beginning of every 1K page which

\ contains high level colon definitions

': doLIST \ list address is in R

pop a pop nop \ get return stack pointer in R1

a! @+ drop ! \ push I on return stack

a push nop a! \ restore R, init new I

\ ': $NEXT \ list address is in A

@+ push ;' \ execute (I), I->I+1

': doVAR \ variable address is in R

push a pop nop \ exchange I and S

a! @+ drop pop \ increment S, copy R to stack

! push a pop \ restore I and S

a! @+ push ;' \ next

': doUSER

pop a push nop \ exchange I and R which points to

\ IS !UP \ user area offset

a! @ 3B0. # nop \ get offset and add to UP

+ push nop a! \ save address, increment S

@+ drop pop ! \ push address on data stack

a pop nop a! \ restore I and S

@+ push ;' \ next

B10. eForth28.seq

\ eForth.seq, adapted from Bill Muench's aFIG.b, 27feb96cht

\ V2.06, slow down I/O for stability of RS232, 11/nov95cht

\ V2.07, merge rectangle routine in hline27, 24nov95cht

\ V20.8, add RECTANGLE to ok28c.seq, add space to 'redef ',

\ use 82C51 for serial communication. 18mar96cht

\ tracker =============================================

\ 950311 improve !IO, add P21 words, V2.04

\ 950227 boot up using serial port, V2.03

\ 950216 compiled successfully

\ 950210 compiled from ok20c

\ 950204 MuP21 bForth

\ 900729 match MASM listing

\ 900708 cleanup editing remove NIP .$

\ 900707 Ting's MASM working

\ 900412 start afig model

\ coyote ==============================================

comment:

CRR .( Memory allocation )

$FFFFF. 2CONSTANT =EM \ end of memory

$00F30. 2CONSTANT =COLD \ cold start vector

$0010. 2CONSTANT =US \ user area size in cells

$0020. 2CONSTANT =RTS \ return stack/TIB size

$03E0. 2CONSTANT =RP \ return stack base

$0310. 2CONSTANT =TIB \ default Terminal Input Buffer

$03C0. 2CONSTANT =SP \ data stack base

$03B0. 2CONSTANT =UP \ user base

comment;

CRR .( System variables ) CRR

810 ORG

VARIABLE tmp 0. #, COMPILE-ONLY \ scratch

VARIABLE SPAN 0. #, \ #chars input by EXPECT

VARIABLE >IN 0. #, \ input buffer offset

VARIABLE #TIB 0. #, \ #chars in the input buffer

310. #, \ TIB

VARIABLE UP 3B0. #, \ user base pointer

VARIABLE CSP 0. #, \ save stack pointers

VARIABLE 'EVAL IS !EVAL 0. #, \ interpret/compile vector

VARIABLE 'NUMBER IS !NUMBER 0. #, \ numeric input vector

CRR

VARIABLE HLD 0. #, \ ptr to converted # string

VARIABLE HANDLER 0. #, \ error frame pointer

VARIABLE CONTEXT 0. #, \ first search vocabulary

\ 8 CELLS ALLOT \ vocabulary stack

0. #, 0. #, 0. #, 0. #, 0. #, 0. #, 0. #, 0. #,

VARIABLE CURRENT 0. #, \ definitions vocabulary

\ 1 CELLS ALLOT \ voc-link newest vocabulary

0. #,

VARIABLE CP 0. #, \ dictionary code pointer

VARIABLE NP 0. #, \ dictionary name pointer

VARIABLE LAST 0. #, \ ptr to last name compiled

CRR .( User variables ) CRR

0 \ start offset

0. USER SP0 \ initial data stack pointer

1. USER RP0 \ initial return stack pointer

2. USER '?KEY \ character input vector

3. USER 'EMIT \ character output vector

CRR

4. USER 'EXPECT \ line input vector

5. USER 'TAP \ input case vector

6. USER 'ECHO \ input echo vector

7. USER 'PROMPT \ operator prompt vector

8. USER BASE \ number base

. ( number of user variables )

CRR .( Common functions ) CRR

:: doVOC ( -- ) R> CONTEXT ! ;;

:: FORTH ( -- ) doVOC 19CE. #, 0. #,

:: ?DUP ( w -- w w | 0 ) DUP IF DUP THEN ;;

:: ROT ( w1 w2 w3 -- w2 w3 w1 ) >R SWAP R> SWAP ;;

:: 2DROP ( w w -- ) DROP DROP ;;

:: 2DUP ( w1 w2 -- w1 w2 w1 w2 ) OVER OVER ;;

:: + ( w w -- w ) UM+ DROP ;;

:: NOT ( w -- w ) -1. LIT XOR ;;

CRR

:: NEGATE ( n -- -n ) NOT 1. LIT + ;;

:: DNEGATE ( d -- -d ) NOT >R NOT 1. LIT UM+ R> + ;;

\ :: D+ ( d d -- d ) >R SWAP >R UM+ R> R> + + ;;

:: - ( w w -- w ) NEGATE + ;;

:: ABS ( n -- +n ) DUP 0< IF NEGATE THEN ;;

CRR .( Comparison ) CRR

:: = ( w w -- t ) XOR IF 0. LIT EXIT THEN -1. LIT ;;

:: U< ( u u -- t ) 2DUP XOR 0< IF SWAP DROP 0< EXIT THEN - 0< ;;

:: < ( n n -- t ) 2DUP XOR 0< IF DROP 0< EXIT THEN - 0< ;;

:: MAX ( n n -- n ) 2DUP < IF SWAP THEN DROP ;;

:: MIN ( n n -- n ) 2DUP SWAP < IF SWAP THEN DROP ;;

:: WITHIN ( u ul uh -- t ) \ ul <= u < uh

OVER - >R - R> U< ;;

CRR .( Divide ) CRR

:: UM/MOD ( ud u -- ur uq )

2DUP U<

IF NEGATE 13. LIT

FOR >R DUP UM+ >R >R DUP UM+ R> + DUP

R> R@ SWAP >R UM+ R> OR

IF >R DROP 1. LIT + R> ELSE DROP THEN R>

NEXT DROP SWAP EXIT

THEN DROP 2DROP -1. LIT DUP ;;

:: M/MOD ( d n -- r q ) \ floored

DUP 0< DUP >R

IF NEGATE >R DNEGATE R>

THEN >R DUP 0< IF R@ + THEN R> UM/MOD R>

IF SWAP NEGATE SWAP THEN ;;

:: /MOD ( n n -- r q ) OVER 0< SWAP M/MOD ;;

:: MOD ( n n -- r ) /MOD DROP ;;

:: / ( n n -- q ) /MOD SWAP DROP ;;

CRR .( Multiply ) CRR

:: UM* ( u u -- ud )

0. LIT SWAP ( u1 0 u2 ) 13. LIT ( 19 decimal )

FOR DUP UM+ >R >R DUP UM+ R> + R>

IF >R OVER UM+ R> + THEN

NEXT ROT DROP ;;

:: * ( n n -- n ) UM* DROP ;;

:: M* ( n n -- d )

2DUP XOR 0< >R ABS SWAP ABS UM* R> IF DNEGATE THEN ;;

:: */MOD ( n n n -- r q ) >R M* R> M/MOD ;;

:: */ ( n n n -- q ) */MOD SWAP DROP ;;

CRR .( Bits & Bytes ) CRR

:: CELL- ( a -- a ) -1. LIT + ;;

:: CELL+ ( a -- a ) 1. LIT + ;;

\ :: CELLS ( n -- n ) ;;

\ :: ALIGNED ( b -- a ) ;;

:: BL ( -- 32 ) 20. LIT ;;

CRR

:: >CHAR ( c -- c )

$7F. LIT AND DUP 7F. LIT BL WITHIN

IF DROP ( CHAR _ ) 5F. LIT THEN ;;

:: DEPTH ( -- n ) SP@ SP0 @ - ;;

:: PICK ( +n -- w ) 1. LIT + SP@ SWAP - @ ;;

CRR .( Memory access ) CRR

:: +! ( n a -- ) SWAP OVER @ + SWAP ! ;;

:: 2! ( d a -- ) SWAP OVER ! CELL+ ! ;;

:: 2@ ( a -- d ) DUP CELL+ @ SWAP @ ;;

:: COUNT ( b -- b +n ) DUP 1. LIT + SWAP C@ ;;

:: HERE ( -- a ) CP @ ;;

:: PAD ( -- a ) HERE 50. LIT + ;;

:: TIB ( -- a ) #TIB CELL+ @ ;;

CRR

:: @EXECUTE ( a -- ) @ ?DUP IF EXECUTE THEN ;;

:: CMOVE ( b b u -- )

FOR AFT >R DUP C@ R@ C! CELL+ R> CELL+ THEN NEXT 2DROP ;;

:: FILL ( b u c -- )

SWAP FOR SWAP AFT 2DUP C! CELL+ THEN NEXT 2DROP ;;

:: -TRAILING ( b u -- b u )

FOR AFT BL OVER R@ + C@ <

IF R> CELL+ EXIT THEN THEN

NEXT 0. LIT ;;

:: PACK$ ( b u a -- a ) \ null fill

DUP >R 2DUP C! CELL+ SWAP CMOVE R> ;;

CRR .( Numeric Output ) CRR \ single precision

:: DIGIT ( u -- c ) 9. LIT OVER < 7. LIT AND +

( CHAR 0 ) 30. LIT + ;;

:: EXTRACT ( n base -- n c ) 0. LIT SWAP UM/MOD SWAP DIGIT ;;

:: <# ( -- ) PAD HLD ! ;;

:: HOLD ( c -- ) HLD @ CELL- DUP HLD ! C! ;;

:: # ( u -- u ) BASE @ EXTRACT HOLD ;;

:: #S ( u -- 0 ) BEGIN # DUP WHILE REPEAT ;;

CRR

:: SIGN ( n -- ) 0< IF ( CHAR - ) 2D. LIT HOLD THEN ;;

:: #> ( w -- b u ) DROP HLD @ PAD OVER - ;;

:: str ( n -- b u ) DUP >R ABS <# #S R> SIGN #> ;;

:: HEX ( -- ) 10. LIT BASE ! ;;

:: DECIMAL ( -- ) 0A. LIT BASE ! ;;

CRR .( Numeric Input ) CRR \ single precision

:: DIGIT? ( c base -- u t )

>R ( CHAR 0 ) 30. LIT - 9. LIT OVER <

IF 7. LIT - DUP 0A. LIT < OR THEN DUP R> U< ;;

!NUMBER FIX

:: NUMBER? ( a -- n T | a F )

BASE @ >R 0. LIT OVER COUNT ( a 0 b n)

OVER C@ ( CHAR $ ) 24. LIT =

IF HEX SWAP CELL+ SWAP CELL- THEN ( a 0 b' n')

OVER C@ ( CHAR - ) 2D. LIT = >R ( a 0 b n)

SWAP R@ - SWAP R@ + ( a 0 b" n") ?DUP

IF CELL- ( a 0 b n)

FOR DUP >R C@ BASE @ DIGIT?

WHILE SWAP BASE @ * + R> CELL+

NEXT DROP R@ ( b ?sign) IF NEGATE THEN SWAP

ELSE R> R> ( b index) 2DROP ( digit number) 2DROP 0. LIT

THEN DUP

THEN R> ( n ?sign) 2DROP R> BASE ! ;;

CRR .( Basic I/O ) CRR

:: ?KEY ( -- c T | F ) '?KEY @EXECUTE ;;

:: KEY ( -- c ) BEGIN ?KEY UNTIL ;;

:: EMIT ( c -- ) 'EMIT @EXECUTE ;;

\ :: NUF? ( -- f ) ?KEY DUP IF 2DROP KEY ( =Cr ) 0D. LIT = THEN ;;

:: PACE ( -- ) 0B. LIT EMIT ;;

:: SPACE ( -- ) BL EMIT ;;

CRR

:: CHARS ( +n c -- ) \ ???ANS conflict

SWAP 0. LIT MAX FOR AFT DUP EMIT THEN NEXT DROP ;;

:: SPACES ( +n -- ) BL CHARS ;;

:: TYPE ( b u -- ) FOR AFT DUP C@ EMIT CELL+ THEN NEXT DROP ;;

:: CR ( -- ) ( =Cr ) 0D. LIT EMIT ( =Lf ) 0A. LIT EMIT ;;

:: do$ ( -- a )

R> R@ R> COUNT + >R SWAP >R ;; COMPILE-ONLY

CRR

:: $"| ( -- a ) do$ ;; COMPILE-ONLY

:: ."| ( -- ) do$ COUNT TYPE ;; COMPILE-ONLY

:: .R ( n +n -- ) >R str R> OVER - SPACES TYPE ;;

:: U.R ( u +n -- ) >R <# #S #> R> OVER - SPACES TYPE ;;

:: U. ( u -- ) <# #S #> SPACE TYPE ;;

:: . ( n -- ) BASE @ 0A. LIT XOR IF U. EXIT THEN str SPACE TYPE ;;

:: ? ( a -- ) @ . ;;

CRR .( Parsing ) CRR

:: (parse) ( b u c -- b u delta ; <string> )

tmp ! OVER >R DUP \ b u u

IF CELL- tmp @ BL =

IF \ b u' \ 'skip'

FOR BL OVER C@ - 0< NOT WHILE CELL+

NEXT ( b) R> DROP 0. LIT DUP EXIT \ all delim

THEN R>

THEN OVER SWAP \ b' b' u' \ 'scan'

FOR tmp @ OVER C@ - tmp @ BL =

IF 0< THEN WHILE CELL+

NEXT DUP >R ELSE R> DROP DUP CELL+ >R

THEN OVER - R> R> - EXIT

THEN ( b u) OVER R> - ;;

:: PARSE ( c -- b u ; <string> )

>R TIB >IN @ + #TIB @ >IN @ - R> (parse) >IN +! ;;

:: CHAR ( -- c ) BL PARSE DROP C@ ;;

:: TOKEN ( -- a ;; <string> )

BL PARSE 1F. LIT MIN NP @ OVER - CELL- PACK$ ;;

:: WORD ( c -- a ; <string> ) PARSE HERE PACK$ ;;

CRR .( Dictionary Search ) CRR

:: NAME> ( a -- xt ) CELL- CELL- @ ;;

:: SAME? ( a a u -- a a f \ -0+ )

FOR AFT OVER R@ + @

OVER R@ + @ - ?DUP

IF R> DROP EXIT THEN THEN

NEXT 0. LIT ;;

:: find ( a va -- xt na | a F ) \ ************ be careful here!!!

SWAP \ va a

DUP C@ tmp ! \ va a \ get cell count !!!

DUP @ >R \ va a \ count

CELL+ SWAP \ a' va

BEGIN @ DUP \ a' na na

IF DUP @ 3F. LIT AND R@ XOR \ ignore lexicon bits

IF CELL+ -1. LIT ELSE CELL+ tmp @ SAME? THEN

ELSE R> DROP SWAP CELL- SWAP EXIT \ a F

THEN

WHILE CELL- CELL- \ a' la

REPEAT R> DROP SWAP DROP CELL- DUP NAME> SWAP ;;

CRR

\ page break. insert doList, doUser and doVar

C10 ORG

:: NAME? ( a -- xt na | a F )

CONTEXT DUP 2@ XOR IF CELL- THEN >R \ context<>also

BEGIN R> CELL+ DUP >R @ ?DUP

WHILE find ?DUP

UNTIL R> DROP EXIT THEN R> DROP 0. LIT ;;

CRR .( Terminal ) CRR

:: ^H ( b b b -- b b b ) \ backspace

>R OVER R> SWAP OVER XOR

IF ( =BkSp ) 8. LIT 'ECHO @EXECUTE

CELL- BL 'ECHO @EXECUTE \ distructive

( =BkSp ) 8. LIT 'ECHO @EXECUTE \ backspace

THEN ;;

:: TAP ( bot eot cur c -- bot eot cur )

DUP 'ECHO @EXECUTE OVER C! CELL+ ;;

:: kTAP ( bot eot cur c -- bot eot cur )

DUP ( =Cr ) 0D. LIT XOR

IF ( =BkSp ) 8. LIT XOR IF BL TAP ELSE ^H THEN EXIT

THEN DROP SWAP DROP DUP ;;

CRR

:: accept ( b u -- b u )

OVER + OVER

BEGIN 2DUP XOR

WHILE KEY DUP BL - 5F. LIT U<

IF TAP ELSE 'TAP @EXECUTE THEN

REPEAT DROP OVER - ;;

:: EXPECT ( b u -- ) 'EXPECT @EXECUTE SPAN ! DROP ;;

:: QUERY ( -- )

TIB 50. LIT 'EXPECT @EXECUTE #TIB ! DROP 0. LIT >IN ! ;;

CRR .( Error handling ) CRR

:: CATCH ( xt -- 0 | err# )

SP@ >R HANDLER @ >R RP@ HANDLER !

EXECUTE

R> HANDLER ! R> DROP 0. LIT ;;

:: THROW ( err# -- err# )

HANDLER @ RP! R> HANDLER ! R> SWAP >R SP! DROP R> ;;

CREATE NULL$ 0. #, 0. #, ( 0 , $," coyote" )

:: ABORT ( -- ) NULL$ THROW ;;

:: abort" ( f -- ) IF do$ THROW THEN do$ DROP ;; COMPILE-ONLY

CRR .( Interpret ) CRR

!EVAL FIX

:: $INTERPRET ( a -- )

NAME? ?DUP

IF @ 40. LIT AND

ABORT" $LIT compile only" EXECUTE EXIT

THEN 'NUMBER @EXECUTE IF EXIT THEN THROW ;;

:: [ ( -- ) DOLIT $INTERPRET 'EVAL ! ;; IMMEDIATE

:: .OK ( -- ) DOLIT $INTERPRET 'EVAL @ = IF SPACE ."| $LIT ok" THEN CR ;;

:: ?STACK ( -- ) DEPTH 0< ABORT" $LIT underflow" ;;

:: EVAL ( -- )

BEGIN TOKEN DUP C@

WHILE 'EVAL @EXECUTE ?STACK

REPEAT DROP 'PROMPT @EXECUTE ;;

CRR .( Shell ) CRR

:: PRESET ( -- ) SP0 @ SP! ( =TIB) 310. LIT #TIB CELL+ ! ;;

:: xio ( a a a -- ) \ reset 'EXPECT 'TAP 'ECHO 'PROMPT

DOLIT accept 'EXPECT 2! 'ECHO 2! ;; COMPILE-ONLY

:: FILE ( -- )

DOLIT PACE DOLIT DROP DOLIT kTAP xio ;;

:: HAND ( -- )

DOLIT .OK DOLIT EMIT DOLIT kTAP xio ;;

CREATE I/O ?RX TX! \ defaults

:: CONSOLE ( -- ) I/O 2@ '?KEY 2! HAND ;;

:: QUIT ( -- )

RP0 @ RP!

BEGIN [

BEGIN QUERY DOLIT EVAL CATCH ?DUP

UNTIL 'PROMPT @ SWAP CONSOLE NULL$ OVER XOR

IF SPACE COUNT TYPE SPACE ."| $LIT ?" CR

THEN DOLIT .OK XOR

IF ( =ERR ) 1B. LIT EMIT THEN

PRESET

AGAIN ;;

CRR .( Compiler Primitives ) CRR

:: ' ( -- xt ) TOKEN NAME? IF EXIT THEN THROW ;;

:: ALLOT ( n -- ) CP +! ;;

:: , ( w -- ) HERE DUP CELL+ CP ! ! ;; \ ???ALIGNED

:: [COMPILE] ( -- ; <string> ) ' , ;; IMMEDIATE

CRR

:: COMPILE ( -- ) R> DUP @ , CELL+ >R ;; COMPILE-ONLY

:: LITERAL doLIT doLIT , , ;; IMMEDIATE

:: $," ( -- ) ( CHAR " ) 22. LIT WORD C@ CELL+ ALLOT ;;

:: RECURSE ( -- ) LAST @ NAME> , ;; IMMEDIATE

CRR .( Name Compiler ) CRR

:: ?UNIQUE ( a -- a )

DUP NAME? IF SPACE ."| $LIT reDef " OVER COUNT TYPE THEN DROP ;;

:: $,n ( a -- )

DUP C@

IF ?UNIQUE

( na) DUP LAST ! \ for OVERT

( na) HERE SWAP

( cp na) CELL-

( cp la) CURRENT @ @

( cp la na') OVER !

( cp la) CELL- DUP NP ! ( ptr) ! EXIT

THEN $"| $LIT name" THROW ;;

CRR .( FORTH Compiler ) CRR

:: $COMPILE ( a -- )

NAME? ?DUP

IF @ 80. LIT AND

IF EXECUTE ELSE , THEN EXIT

THEN 'NUMBER @EXECUTE

IF LITERAL EXIT

THEN THROW ;;

:: OVERT ( -- ) LAST @ CURRENT @ ! ;;

:: ; ( -- )

COMPILE EXIT [ OVERT ;; COMPILE-ONLY IMMEDIATE

:: ] ( -- ) DOLIT $COMPILE 'EVAL ! ;;

:: : ( -- ; <string> ) TOKEN $,n ( ' doLIST 8155.) A2BFF. LIT , ] ;;

CRR .( Defining Words ) CRR

:: code ( -- ; <string> ) TOKEN $,n OVERT ;;

:: USER ( n -- ; <string> )

code ( 815D.) A2BF7. LIT , ;;

CRR .( Tools ) CRR

:: _TYPE ( b u -- )

FOR AFT DUP C@ >CHAR EMIT CELL+ THEN NEXT DROP ;;

:: dm+ ( b u -- b )

OVER 5. LIT U.R SPACE FOR AFT DUP C@ 6. LIT U.R CELL+ THEN NEXT ;;

:: DUMP ( b u -- )

BASE @ >R HEX 8. LIT /

FOR CR 8. LIT 2DUP dm+ ROT ROT 2. LIT SPACES _TYPE

NEXT DROP R> BASE ! ;;

:: .S ( -- ) SPACE DEPTH FOR AFT R@ PICK . THEN NEXT ;;

:: .BASE ( -- ) BASE @ DECIMAL DUP . BASE ! ;;

:: .FREE ( -- ) NP @ CP @ - U. ;;

CRR

:: !CSP ( -- ) SP@ CSP ! ;;

:: ?CSP ( -- ) SP@ CSP @ XOR ABORT" $LIT stack depth" ;;

:: >NAME ( xt -- na | F )

CURRENT

BEGIN CELL+ @ ?DUP WHILE 2DUP

BEGIN @ DUP WHILE 2DUP NAME> XOR

WHILE CELL-

REPEAT THEN SWAP DROP ?DUP

UNTIL SWAP DROP SWAP DROP EXIT THEN DROP 0. LIT ;;

:: .ID ( a -- )

?DUP IF COUNT $01F. LIT AND _TYPE EXIT THEN SPACE ."| $LIT {noName}" ;;

:: SEE ( -- ; <string> )

' CR

BEGIN

20. LIT FOR

CELL+ DUP @ DUP IF >NAME THEN ?DUP

IF SPACE .ID ELSE DUP @ U. THEN

NEXT KEY 0D. LIT = \ can't use ESC on terminal

UNTIL DROP ;;

:: WORDS ( -- )

CR CONTEXT @

BEGIN @ ?DUP

WHILE DUP SPACE .ID CELL-

REPEAT ;;

CRR .( Hardware reset ) CRR

\ version

:: VER ( -- u ) 208. LIT ;;

:: hi ( -- )

!IO

HEX \ !IO \ initialize IO device & sign on

CR ."| $LIT MuP21 eForth V"

VER <# # # ( CHAR . ) 2E. LIT HOLD # #> TYPE

CR DECIMAL

;; COMPILE-ONLY

:: EMPTY ( -- )

FORTH CONTEXT @ DUP CURRENT 2! \ init vocabulary

DOLIT IS !CP 0. #, CP ! \ init code dictionary pointer

DOLIT IS !NP 0. #, NP ! \ init name dictionary pointer

DOLIT IS !LAST 0. #, LAST ! \ init last name field pointer

OVERT ;; \ init vocabulary link

CREATE 'BOOT hi \ application vector

CREATE up' \ MUST match user, room for 12

3C0. #, ( SP0) 3E0. #, ( RP0 ) ?RX TX!

accept kTap TX! .OK

0A. #, ( base ) 0. #, 0. #, 0. #,

:: COLD ( -- )

BEGIN

!cold 1. D+ FIX

up' UP @ ( #USER ) 9. LIT CMOVE \ ???

PRESET 'BOOT @EXECUTE

EMPTY \ FORTH CONTEXT @ DUP CURRENT 2! OVERT

QUIT

AGAIN ;;

CRR .( Structures ) CRR

:: <MARK ( -- a ) HERE ;;

:: <RESOLVE ( a -- ) , ;;

:: >MARK ( -- A ) HERE 0. LIT , ;;

:: >RESOLVE ( A -- ) <MARK SWAP ! ;;

CRR

:: FOR ( -- a ) COMPILE >R <MARK ;; IMMEDIATE

:: BEGIN ( -- a ) <MARK ;; IMMEDIATE

:: NEXT ( a -- ) COMPILE doNEXT <RESOLVE ;; IMMEDIATE

:: UNTIL ( a -- ) COMPILE qbranch <RESOLVE ;; IMMEDIATE

:: AGAIN ( a -- ) COMPILE branch <RESOLVE ;; IMMEDIATE

:: IF ( -- A ) COMPILE qbranch >MARK ;; IMMEDIATE

CRR

:: AHEAD ( -- A ) COMPILE branch >MARK ;; IMMEDIATE

:: REPEAT ( A a -- ) AGAIN >RESOLVE ;; IMMEDIATE

:: THEN ( A -- ) >RESOLVE ;; IMMEDIATE

:: AFT ( a -- a A ) DROP AHEAD BEGIN SWAP ;; IMMEDIATE

:: ELSE ( A -- A ) AHEAD SWAP THEN ;; IMMEDIATE

:: WHEN ( a A -- a A a ) IF OVER ;; IMMEDIATE

:: WHILE ( a -- A a ) IF SWAP ;; IMMEDIATE

CRR

:: ABORT" ( -- ; <string> ) COMPILE abort" $," ;; IMMEDIATE

:: $" ( -- ; <string> ) COMPILE $"| $," ;; IMMEDIATE

:: ." ( -- ; <string> ) COMPILE ."| $," ;; IMMEDIATE

:: CREATE ( -- ; <string> )

code ( 8151.) A2BFB. LIT , ;;

:: VARIABLE ( -- ; <string> ) CREATE 0. LIT , ;;

CRR

:: .( ( -- ) 29. LIT PARSE TYPE ;; IMMEDIATE

:: \ ( -- ) #TIB @ >IN ! ;; IMMEDIATE

:: ( 29. LIT PARSE 2DROP ;; IMMEDIATE

:: IMMEDIATE 80. LIT LAST @ @ OR LAST @ ! ;;

CRR

1010. AAAAA. 2-OR !CP forthDROP 1- R!

nameH forth@ 0 AAAAA. 2-OR !NP forthDROP 1- R!

lastH forth@ 0 AAAAA. 2-OR !LAST forthDROP 1- R!